Initial work on setoids:

[helm.git] / components / cic_disambiguation / disambiguate.ml

diff --git a/components/cic_disambiguation/disambiguate.ml b/components/cic_disambiguation/disambiguate.ml
index d3af052564b5e206303d8adb7338203f6f280592..fb4c338a447ee040ac8c4ecb63dfad86c149b31d 100644 (file)
--- a/components/cic_disambiguation/disambiguate.ml
+++ b/components/cic_disambiguation/disambiguate.ml
@@ -483,7 +483,7 @@ let interpretate_obj ~context ~env ~uri ~is_path obj ~localization_tbl =
      let fields' =
       snd (
        List.fold_left
-        (fun (context,res) (name,ty,_coercion) ->
+        (fun (context,res) (name,ty,_coercion,arity) ->
           let context' = Cic.Name name :: context in
            context',(name,interpretate_term context env None false ty)::res
         ) (context,[]) fields) in
@@ -500,16 +500,19 @@ let interpretate_obj ~context ~env ~uri ~is_path obj ~localization_tbl =
        concl fields' in
      let con' = add_params con in
      let tyl = [name,true,ty',["mk_" ^ name,con']] in
-     let field_names = List.map (fun (x,_,y) -> x,y) fields in
+     let field_names = List.map (fun (x,_,y,z) -> x,y,z) fields in
       Cic.InductiveDefinition
        (tyl,[],List.length params,[`Class (`Record field_names)])
   | CicNotationPt.Theorem (flavour, name, ty, bo) ->
      let attrs = [`Flavour flavour] in
      let ty' = interpretate_term [] env None false ty in
-     (match bo with
-        None ->
+     (match bo,flavour with
+        None,`Axiom ->
+         Cic.Constant (name,None,ty',[],attrs)
+      | Some bo,`Axiom -> assert false
+      | None,_ ->
          Cic.CurrentProof (name,[],Cic.Implicit None,ty',[],attrs)
-      | Some bo ->
+      | Some bo,_ ->
          let bo' = Some (interpretate_term [] env None false bo) in
           Cic.Constant (name,bo',ty',[],attrs))
           
@@ -689,7 +692,7 @@ let domain_of_obj ~context ast =
    | CicNotationPt.Record (params,_,ty,fields) ->
       let dom =
        List.flatten
-        (List.rev_map (fun (_,ty,_) -> domain_rev_of_term [] ty) fields) in
+        (List.rev_map (fun (_,ty,_,_) -> domain_rev_of_term [] ty) fields) in
       let dom =
        List.fold_left
         (fun dom (_,ty) ->
@@ -699,7 +702,7 @@ let domain_of_obj ~context ast =
        List.filter
         (fun (_,name) ->
           not (  List.exists (fun (name',_) -> name = Id name') params
-              || List.exists (fun (name',_,_) -> name = Id name') fields)
+              || List.exists (fun (name',_,_,_) -> name = Id name') fields)
         ) dom
  in
   rev_uniq domain_rev
@@ -707,9 +710,19 @@ let domain_of_obj ~context ast =
   (* dom1 \ dom2 *)
 let domain_diff dom1 dom2 =
 (* let domain_diff = Domain.diff *)
-  let is_in_dom2 =
-    List.fold_left (fun pred elt -> (fun elt' -> elt' = elt || pred elt'))
-      (fun _ -> false) dom2
+  let is_in_dom2 elt =
+    List.exists
+     (function
+       | Symbol (symb, 0) ->
+          (match elt with
+              Symbol (symb',_) when symb = symb' -> true
+            | _ -> false)
+       | Num i ->
+          (match elt with
+              Num _ -> true
+            | _ -> false)
+       | item -> elt = item
+     ) dom2
   in
   List.filter (fun (_,elt) -> not (is_in_dom2 elt)) dom1
 
@@ -830,7 +843,7 @@ let refine_profiler = HExtlib.profile "disambiguate_thing.refine_thing"
                     | item -> item
                   in
                   Environment.find item e
-                with Not_found -> [])
+                with Not_found -> lookup_in_library ())
           in
           choices
       in