+let show_query_results results =
+ let window =
+ GWindow.window
+ ~modal:false ~title:"Query results." ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:window#add () in
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:"Click on a URI to show that object"
+ ~packing:hbox#add () in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height:400 ~width:600
+ ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in
+ let clist = GList.clist ~columns:1 ~packing:scrolled_window#add () in
+ ignore
+ (List.map
+ (function (uri,_) ->
+ let n =
+ clist#append [uri]
+ in
+ clist#set_row ~selectable:false n
+ ) results
+ ) ;
+ clist#columns_autosize () ;
+ ignore
+ (clist#connect#select_row
+ (fun ~row ~column ~event ->
+ let (uristr,_) = List.nth results row in
+ match
+ cic_textual_parser_uri_of_string
+ (wrong_xpointer_format_from_wrong_xpointer_format' uristr)
+ with
+ CicTextualParser0.ConUri uri
+ | CicTextualParser0.VarUri uri
+ | CicTextualParser0.IndTyUri (uri,_)
+ | CicTextualParser0.IndConUri (uri,_,_) ->
+ show_in_show_window_uri uri
+ )
+ ) ;
+ window#show ()
+;;
+
+let refine_constraints (must_obj,must_rel,must_sort) =
+ let chosen = ref false in
+ let use_only = ref false in
+ let window =
+ GWindow.window
+ ~modal:true ~title:"Constraints refinement."
+ ~width:800 ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:window#add () in
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text: "\"Only\" constraints can be enforced or not."
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let onlyb =
+ GButton.toggle_button ~label:"Enforce \"only\" constraints"
+ ~active:false ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) ()
+ in
+ ignore
+ (onlyb#connect#toggled (function () -> use_only := onlyb#active)) ;
+ (* Notebook for the constraints choice *)
+ let notebook =
+ GPack.notebook ~scrollable:true
+ ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in
+ (* Rel constraints *)
+ let label =
+ GMisc.label
+ ~text: "Constraints on Rels" () in
+ let vbox' =
+ GPack.vbox ~packing:(notebook#append_page ~tab_label:label#coerce)
+ () in
+ let hbox =
+ GPack.hbox ~packing:(vbox'#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text: "You can now specify the constraints on Rels."
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let expected_height = 25 * (List.length must_rel + 2) in
+ let height = if expected_height > 400 then 400 else expected_height in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height ~width:600
+ ~packing:(vbox'#pack ~expand:true ~fill:true ~padding:5) () in
+ let scrolled_vbox = GPack.vbox ~packing:scrolled_window#add_with_viewport () in
+ let rel_constraints =
+ List.map
+ (function (position,depth) ->
+ let hbox =
+ GPack.hbox
+ ~packing:(scrolled_vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:position
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ match depth with
+ None -> position, ref None
+ | Some depth' ->
+ let mutable_ref = ref (Some depth') in
+ let depthb =
+ GButton.toggle_button
+ ~label:("depth = " ^ string_of_int depth') ~active:true
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) ()
+ in
+ ignore
+ (depthb#connect#toggled
+ (function () ->
+ let sel_depth = if depthb#active then Some depth' else None in
+ mutable_ref := sel_depth
+ )) ;
+ position, mutable_ref
+ ) must_rel in
+ (* Sort constraints *)
+ let label =
+ GMisc.label
+ ~text: "Constraints on Sorts" () in
+ let vbox' =
+ GPack.vbox ~packing:(notebook#append_page ~tab_label:label#coerce)
+ () in
+ let hbox =
+ GPack.hbox ~packing:(vbox'#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text: "You can now specify the constraints on Sorts."
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let expected_height = 25 * (List.length must_sort + 2) in
+ let height = if expected_height > 400 then 400 else expected_height in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height ~width:600
+ ~packing:(vbox'#pack ~expand:true ~fill:true ~padding:5) () in
+ let scrolled_vbox = GPack.vbox ~packing:scrolled_window#add_with_viewport () in
+ let sort_constraints =
+ List.map
+ (function (position,depth,sort) ->
+ let hbox =
+ GPack.hbox
+ ~packing:(scrolled_vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:(sort ^ " " ^ position)
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ match depth with
+ None -> position, ref None, sort
+ | Some depth' ->
+ let mutable_ref = ref (Some depth') in
+ let depthb =
+ GButton.toggle_button ~label:("depth = " ^ string_of_int depth')
+ ~active:true
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) ()
+ in
+ ignore
+ (depthb#connect#toggled
+ (function () ->
+ let sel_depth = if depthb#active then Some depth' else None in
+ mutable_ref := sel_depth
+ )) ;
+ position, mutable_ref, sort
+ ) must_sort in
+ (* Obj constraints *)
+ let label =
+ GMisc.label
+ ~text: "Constraints on constants" () in
+ let vbox' =
+ GPack.vbox ~packing:(notebook#append_page ~tab_label:label#coerce)
+ () in
+ let hbox =
+ GPack.hbox ~packing:(vbox'#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text: "You can now specify the constraints on constants."
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let expected_height = 25 * (List.length must_obj + 2) in
+ let height = if expected_height > 400 then 400 else expected_height in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height ~width:600
+ ~packing:(vbox'#pack ~expand:true ~fill:true ~padding:5) () in
+ let scrolled_vbox = GPack.vbox ~packing:scrolled_window#add_with_viewport () in
+ let obj_constraints =
+ List.map
+ (function (uri,position,depth) ->
+ let hbox =
+ GPack.hbox
+ ~packing:(scrolled_vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:(uri ^ " " ^ position)
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ match depth with
+ None -> uri, position, ref None
+ | Some depth' ->
+ let mutable_ref = ref (Some depth') in
+ let depthb =
+ GButton.toggle_button ~label:("depth = " ^ string_of_int depth')
+ ~active:true
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) ()
+ in
+ ignore
+ (depthb#connect#toggled
+ (function () ->
+ let sel_depth = if depthb#active then Some depth' else None in
+ mutable_ref := sel_depth
+ )) ;
+ uri, position, mutable_ref
+ ) must_obj in
+ (* Confirm/abort buttons *)
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let okb =
+ GButton.button ~label:"Ok"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let cancelb =
+ GButton.button ~label:"Abort"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) ()
+ in
+ ignore (window#connect#destroy GMain.Main.quit) ;
+ ignore (cancelb#connect#clicked window#destroy) ;
+ ignore
+ (okb#connect#clicked (function () -> chosen := true ; window#destroy ()));
+ window#set_position `CENTER ;
+ window#show () ;
+ GMain.Main.main () ;
+ if !chosen then
+ let chosen_must_rel =
+ List.map
+ (function (position,ref_depth) -> position,!ref_depth) rel_constraints in
+ let chosen_must_sort =
+ List.map
+ (function (position,ref_depth,sort) -> position,!ref_depth,sort)
+ sort_constraints
+ in
+ let chosen_must_obj =
+ List.map
+ (function (uri,position,ref_depth) -> uri,position,!ref_depth)
+ obj_constraints
+ in
+ (chosen_must_obj,chosen_must_rel,chosen_must_sort),
+ (if !use_only then
+(*CSC: ???????????????????????? I assume that must and only are the same... *)
+ Some chosen_must_obj,Some chosen_must_rel,Some chosen_must_sort
+ else
+ None,None,None
+ )
+ else
+ raise NoChoice
+;;