Change Sort.merge (deprecated) with List.merge

[helm.git] / matita / components / ng_tactics / nTacStatus.ml

diff --git a/matita/components/ng_tactics/nTacStatus.ml b/matita/components/ng_tactics/nTacStatus.ml
index 143aac98e6294e9e35825bf9450e5a5fab8f4ba0..1001d980854605340166d0e8cb7055d5d876665e 100644 (file)
--- a/matita/components/ng_tactics/nTacStatus.ml
+++ b/matita/components/ng_tactics/nTacStatus.ml
@@ -29,9 +29,12 @@ let wrap fname f x =
   with 
   | MultiPassDisambiguator.DisambiguationError _ 
   | NCicRefiner.RefineFailure _ 
+  | NCicRefiner.Uncertain _ 
   | NCicUnification.UnificationFailure _ 
+  | NCicUnification.Uncertain _ 
   | NCicTypeChecker.TypeCheckerFailure _ 
-  | NCicMetaSubst.MetaSubstFailure _ as exn -> fail ~exn (lazy fname)
+  | NCicMetaSubst.MetaSubstFailure _
+  | NCicMetaSubst.Uncertain _ as exn -> fail ~exn (lazy fname)
 ;;
 
 class type g_eq_status =
@@ -184,9 +187,11 @@ let term_of_cic_term s t c =
 let disambiguate status context t ty =
  let status, expty = 
    match ty with 
-   | None -> status, None 
-   | Some ty -> 
-       let status, (_,x) = relocate status context ty in status, Some x 
+   | `XTSome ty -> 
+       let status, (_,x) = relocate status context ty in status, `XTSome x 
+   | `XTNone -> status, `XTNone 
+   | `XTSort -> status, `XTSort
+   | `XTInd  -> status, `XTInd
  in
  let uri,height,metasenv,subst,obj = status#obj in
  let metasenv, subst, status, t = 
@@ -227,6 +232,15 @@ let normalize status ?delta ctx t =
   status, (ctx, t)
 ;;
   
+let are_convertible status ctx a b =
+  let status, (_,a) = relocate status ctx a in
+  let status, (_,b) = relocate status ctx b in
+  let n,h,metasenv,subst,o = status#obj in
+  let res = NCicReduction.are_convertible status metasenv subst ctx a b in
+   status, res
+;;
+let are_convertible a b c d = wrap "are_convertible" (are_convertible a b c) d;;
+
 let unify status ctx a b =
   let status, (_,a) = relocate status ctx a in
   let status, (_,b) = relocate status ctx b in
@@ -251,9 +265,11 @@ let refine status ctx term expty =
   let status, (_,term) = relocate status ctx term in
   let status, expty = 
     match expty with
-      None -> status, None 
-    | Some e -> 
-        let status, (_, e) = relocate status ctx e in status, Some e
+    | `XTSome e -> 
+        let status, (_, e) = relocate status ctx e in status, `XTSome e
+    | `XTNone -> status, `XTNone 
+    | `XTSort -> status, `XTSort
+    | `XTInd  -> status, `XTInd
   in
   let name,height,metasenv,subst,obj = status#obj in
   let metasenv,subst,t,ty = 
@@ -286,7 +302,7 @@ let instantiate status ?refine:(dorefine=true) i t =
  let _,_,metasenv,_,_ = status#obj in
  let gname, context, gty = List.assoc i metasenv in
   if dorefine then
-   let status, (_,t), (_,ty) = refine status context t (Some (context,gty)) in
+   let status, (_,t), (_,ty) = refine status context t (`XTSome (context,gty)) in
     to_subst status i (gname,context,t,ty)
   else
    let status,(_,ty) = typeof status context t in
@@ -297,7 +313,7 @@ let instantiate_with_ast status i t =
  let _,_,metasenv,_,_ = status#obj in
  let gname, context, gty = List.assoc i metasenv in
  let ggty = mk_cic_term context gty in
- let status, (_,t) = disambiguate status context t (Some ggty) in
+ let status, (_,t) = disambiguate status context t (`XTSome ggty) in
   to_subst status i (gname,context,t,gty)
 ;;
 
@@ -397,7 +413,7 @@ let select_term
         let ctx = (n, NCic.Decl s2) :: ctx in
         let status, t = select status ctx t1 t2 in
         status, NCic.Prod (n,s,t)
-    | NCic.Appl l1, NCic.Appl l2 ->
+    | NCic.Appl l1, NCic.Appl l2 when List.length l1 = List.length l2 ->
         let status, l = 
            List.fold_left2
              (fun (status,l) x y -> 
@@ -406,7 +422,8 @@ let select_term
              (status,[]) l1 l2
         in
         status, NCic.Appl (List.rev l)
-    | NCic.Match (_,ot1,t1,pl1), NCic.Match (u,ot2,t2,pl2) ->
+    | NCic.Match (_,ot1,t1,pl1), NCic.Match (u,ot2,t2,pl2)
+      when List.length pl1 = List.length pl2 ->
         let status, t = select status ctx t1 t2 in
         let status, ot = select status ctx ot1 ot2 in
         let status, pl = 
@@ -420,7 +437,7 @@ let select_term
     | NCic.Implicit `Hole, t -> 
         (match wanted with
         | Some wanted -> 
-             let status', wanted = disambiguate status ctx wanted None in
+             let status', wanted = disambiguate status ctx wanted `XTNone in
              pp(lazy("wanted: "^ppterm status' wanted));
              let (status',found), t' = match_term status' ctx wanted t in
               if found then status',t' else status,t
@@ -452,7 +469,7 @@ let analyse_indty status ty =
  let _,_,_,cl = List.nth tl i in
  let consno = List.length cl in
  let left, right = HExtlib.split_nth lno args in
- status, (ref, consno, left, right)
+ status, (ref, consno, left, right, cl)
 ;;
 
 let apply_subst status ctx t =