mathql_generator: new constraint format (more type safe)

[helm.git] / helm / gTopLevel / gTopLevel.ml

diff --git a/helm/gTopLevel/gTopLevel.ml b/helm/gTopLevel/gTopLevel.ml
index 0ceb6f2af7a8d436a0831cc8a6c9725893ecf66b..f1710cfce134d60e09f8cdaa3f7d79492402b61e 100644 (file)
--- a/helm/gTopLevel/gTopLevel.ml
+++ b/helm/gTopLevel/gTopLevel.ml
@@ -39,6 +39,8 @@ open Printf;;
 
 module MQI  = MQueryInterpreter
 module MQIC = MQIConn
+module MQGT = MQGTypes
+module MQGU = MQGUtil
 module MQG  = MQueryGenerator
 
 (* GLOBAL CONSTANTS *)
@@ -1756,32 +1758,36 @@ let refine_constraints (must_obj,must_rel,must_sort) =
   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 mk_depth_button (hbox:GPack.box) d =
+    let mutable_ref = ref (Some d) in
+    let depthb =
+     GButton.toggle_button
+      ~label:("depth = " ^ string_of_int d) 
+      ~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 d else None in
+         mutable_ref := sel_depth
+       )) ; mutable_ref
+ in
  let rel_constraints =
   List.map
-   (function (position,depth) ->
+   (function p ->
      let hbox =
       GPack.hbox
        ~packing:(scrolled_vbox#pack ~expand:false ~fill:false ~padding:5) () in
      let lMessage =
       GMisc.label
-       ~text:position
+       ~text:(MQGU.text_of_position (p:>MQGT.full_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
+     match p with
+      | `MainHypothesis None 
+      | `MainConclusion None -> p, ref None
+      | `MainHypothesis (Some depth') 
+      | `MainConclusion (Some depth') -> p, mk_depth_button hbox depth'
    ) must_rel in
  (* Sort constraints *)
  let label =
@@ -1804,30 +1810,19 @@ let refine_constraints (must_obj,must_rel,must_sort) =
  let scrolled_vbox = GPack.vbox ~packing:scrolled_window#add_with_viewport () in
  let sort_constraints =
   List.map
-   (function (position,depth,sort) ->
+   (function (p, sort) ->
      let hbox =
       GPack.hbox
        ~packing:(scrolled_vbox#pack ~expand:false ~fill:false ~padding:5) () in
      let lMessage =
       GMisc.label
-       ~text:(sort ^ " " ^ position)
+       ~text:(MQGU.text_of_sort sort ^ " " ^ MQGU.text_of_position (p:>MQGT.full_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
+     match p with
+      | `MainHypothesis None 
+      | `MainConclusion None -> p, ref None, sort
+      | `MainHypothesis (Some depth') 
+      | `MainConclusion (Some depth') -> p, mk_depth_button hbox depth', sort
    ) must_sort in
  (* Obj constraints *)
  let label =
@@ -1850,30 +1845,22 @@ let refine_constraints (must_obj,must_rel,must_sort) =
  let scrolled_vbox = GPack.vbox ~packing:scrolled_window#add_with_viewport () in
  let obj_constraints =
   List.map
-   (function (uri,position,depth) ->
+   (function (p, uri) ->
      let hbox =
       GPack.hbox
        ~packing:(scrolled_vbox#pack ~expand:false ~fill:false ~padding:5) () in
      let lMessage =
       GMisc.label
-       ~text:(uri ^ " " ^ position)
+       ~text:(uri ^ " " ^ (MQGU.text_of_position p))
        ~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
+     match p with
+      | `InBody
+      | `InHypothesis 
+      | `InConclusion 
+      | `MainHypothesis None 
+      | `MainConclusion None -> p, ref None, uri
+      | `MainHypothesis (Some depth') 
+      | `MainConclusion (Some depth') -> p, mk_depth_button hbox depth', uri
    ) must_obj in
  (* Confirm/abort buttons *)
  let hbox =
@@ -1895,15 +1882,18 @@ let refine_constraints (must_obj,must_rel,must_sort) =
   if !chosen then
    let chosen_must_rel =
     List.map
-     (function (position,ref_depth) -> position,!ref_depth) rel_constraints in
+     (function (position, ref_depth) -> MQGU.set_main_position position !ref_depth)
+     rel_constraints
+   in
    let chosen_must_sort =
     List.map
-     (function (position,ref_depth,sort) -> position,!ref_depth,sort)
+     (function (position, ref_depth, sort) -> 
+      MQGU.set_main_position position !ref_depth,sort)
      sort_constraints
    in
    let chosen_must_obj =
     List.map
-     (function (uri,position,ref_depth) -> uri,position,!ref_depth)
+     (function (position, ref_depth, uri) -> MQGU.set_full_position position !ref_depth, uri)
      obj_constraints
    in
     (chosen_must_obj,chosen_must_rel,chosen_must_sort),
@@ -1925,14 +1915,7 @@ let completeSearchPattern () =
    let must = MQueryLevels2.get_constraints expr in
    let must',only = refine_constraints must in
    let query =
-    MQG.query_of_constraints
-     (Some
-       ["http://www.cs.unibo.it/helm/schemas/schema-helm#MainConclusion" ;
-        "http://www.cs.unibo.it/helm/schemas/schema-helm#MainHypothesis" ;
-        "http://www.cs.unibo.it/helm/schemas/schema-helm#InConclusion" ;
-        "http://www.cs.unibo.it/helm/schemas/schema-helm#InHypothesis"
-       ])
-     must' only
+    MQG.query_of_constraints (Some MQGU.universe_for_search_pattern) must' only
    in
    let results = MQI.execute mqi_handle query in 
     show_query_results results
@@ -2148,7 +2131,7 @@ let searchPattern () =
       | None -> ()
       | Some metano ->
          let uris' =
-           TacticChaser.searchPattern
+           TacticChaser.matchConclusion
            mqi_handle
             ~output_html:(output_html outputhtml) ~choose_must ()
             ~status:(proof, metano)