The unification does not longer use the refiner (urrah!)

[helm.git] / helm / software / components / ng_refiner / nCicUnification.ml

diff --git a/helm/software/components/ng_refiner/nCicUnification.ml b/helm/software/components/ng_refiner/nCicUnification.ml
index fc6eea759313223b30c57a7b6215470ea12c24d5..cf44ff4708946917e62fd397479caea6af471365 100644 (file)
--- a/helm/software/components/ng_refiner/nCicUnification.ml
+++ b/helm/software/components/ng_refiner/nCicUnification.ml
@@ -15,11 +15,6 @@ exception UnificationFailure of string Lazy.t;;
 exception Uncertain of string Lazy.t;;
 exception AssertFailure of string Lazy.t;;
 
-let refiner_typeof =
- ref (fun _ ?localise _ _ _ _ _ -> ignore localise; assert false);;
-let set_refiner_typeof f = refiner_typeof := f
-;;
-
 let (===) x y = Pervasives.compare x y = 0 ;;
 
 let uncert_exc metasenv subst context t1 t2 = 
@@ -96,13 +91,15 @@ let pp s =
   prerr_endline (Printf.sprintf "%-20s" !indent ^ " " ^ Lazy.force s)
 ;;
 
-let ppcontext = NCicPp.ppcontext;;
-let ppmetasenv = NCicPp.ppmetasenv;;
+let pp _ = ();;
 
-let ppcontext ~metasenv:_metasenv ~subst:_subst _context = "...";;
-let ppmetasenv ~subst:_subst _metasenv = "...";;
+let ppcontext ~metasenv ~subst c = 
+      "\nctx:\n"^ NCicPp.ppcontext ~metasenv ~subst c
+;;
+let ppmetasenv ~subst m = "\nmenv:\n" ^ NCicPp.ppmetasenv ~subst m;;
 
-let pp _ = ();;
+let ppcontext ~metasenv:_metasenv ~subst:_subst _context = "";;
+let ppmetasenv ~subst:_subst _metasenv = "";;
 
 let fix_sorts swap exc t =
   let rec aux () = function
@@ -152,27 +149,30 @@ let rec lambda_intros rdb metasenv subst context t args =
        in
        metasenv, subst, bo
    | (arg,ty)::tail ->
+       pp(lazy("arg{ " ^ 
+         NCicPp.ppterm ~metasenv ~subst ~context:context_of_args arg ^  ":" ^
+         NCicPp.ppterm ~metasenv ~subst ~context:context_of_args ty));
+       let metasenv, subst, telescopic_ty = 
+         if processed_args = [] then metasenv, subst, ty else
+         let _ = pp(lazy("delift")) in
+         delift_type_wrt_terms rdb metasenv subst context_of_args ty 
+           (List.rev processed_args)
+       in
+       pp(lazy("arg}"));
        let name = "HBeta"^string_of_int n in
-       let metasenv,_,instance,_ =
-        NCicMetaSubst.mk_meta metasenv context_of_args `Term in
-       let meta_applied =
-        NCicUntrusted.mk_appl instance (List.rev processed_args) in
-let metasenv,subst,_,_ =
- !refiner_typeof ((rdb :> NRstatus.status)#set_coerc_db NCicCoercion.empty_db) metasenv subst context_of_args meta_applied None
-in
-       let metasenv,subst =
-        unify rdb true metasenv subst context_of_args meta_applied ty in
-       let telescopic_ty = NCicSubstitution.lift n instance in
-       let telescopic_ty =
-        NCicUntrusted.mk_appl
-         telescopic_ty (mk_irl (List.length processed_args)) in
        let metasenv, subst, bo =
         mk_lambda metasenv subst ((name,NCic.Decl telescopic_ty)::context) (n+1)
          (arg::processed_args) tail
        in
         metasenv, subst, NCic.Lambda (name, telescopic_ty, bo)
  in
-   mk_lambda metasenv subst context 0 [] argsty
+ pp(lazy("LAMBDA_INTROS{ " ^ 
+   NCicPp.ppterm ~metasenv ~subst ~context t ^  ":" ^
+   NCicPp.ppterm ~metasenv ~subst ~context tty ^ " over " ^ 
+   String.concat "," (List.map (NCicPp.ppterm ~metasenv ~subst ~context)args)));
+ let rc = mk_lambda metasenv subst context 0 [] argsty in
+ pp(lazy("LAMBDA_INTROS}"));
+ rc
 
 and instantiate rdb test_eq_only metasenv subst context n lc t swap =
  (*D*)  inside 'I'; try let rc =  
@@ -190,8 +190,8 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap =
          (* fix_sorts swap metasenv subst context (NCic.Meta(n,lc)) t *)
     | _ ->
        pp (lazy (
-         "typeof: " ^ NCicPp.ppterm ~metasenv ~subst ~context t ^ "\nctx:\n"^
-          ppcontext ~metasenv ~subst context ^ "\nmenv:\n"^
+               "typeof: " ^ NCicPp.ppterm ~metasenv ~subst ~context t ^
+          ppcontext ~metasenv ~subst context ^ 
           ppmetasenv ~subst metasenv));
        let exc_to_be = fail_exc metasenv subst context (NCic.Meta (n,lc)) t in
        let t, ty_t = 
@@ -203,8 +203,8 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap =
            if ft == t then 
              (prerr_endline ( ("ILLTYPED: " ^ 
                 NCicPp.ppterm ~metasenv ~subst ~context t
-            ^ "\nBECAUSE:" ^ Lazy.force msg ^ "\nCONTEXT:\n" ^
-            ppcontext ~metasenv ~subst context ^ "\nMENV:\n" ^
+            ^ "\nBECAUSE:" ^ Lazy.force msg ^ 
+            ppcontext ~metasenv ~subst context ^ 
             ppmetasenv ~subst metasenv
             ));
                      assert false)
@@ -217,6 +217,10 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap =
               assert false)
          | NCicTypeChecker.TypeCheckerFailure msg ->
               prerr_endline (Lazy.force msg);
+       prerr_endline (
+               "typeof: " ^ NCicPp.ppterm ~metasenv ~subst ~context t ^
+          ppcontext ~metasenv ~subst context ^ 
+          ppmetasenv ~subst metasenv);
               pp msg; assert false
        in
        let lty = NCicSubstitution.subst_meta lc ty in
@@ -260,7 +264,7 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap =
   in
          pp (lazy(string_of_int n ^ " := 222 = "^
            NCicPp.ppterm ~metasenv ~subst ~context:ctx t
-         ^ "\n" ^ ppmetasenv ~subst metasenv));
+         ^ ppmetasenv ~subst metasenv));
   (* Unifying the types may have already instantiated n. *)
   try
     let _, _,oldt,_ = NCicUtils.lookup_subst n subst in
@@ -285,7 +289,7 @@ and unify rdb test_eq_only metasenv subst context t1 t2 =
    let fo_unif test_eq_only metasenv subst t1 t2 =
     (*D*) inside 'F'; try let rc =  
      pp (lazy("  " ^ NCicPp.ppterm ~metasenv ~subst ~context t1 ^ " ==?== " ^ 
-         NCicPp.ppterm ~metasenv ~subst ~context t2 ^ "\n" ^ ppmetasenv
+         NCicPp.ppterm ~metasenv ~subst ~context t2 ^ ppmetasenv
          ~subst metasenv));
      if t1 === t2 then
        metasenv, subst
@@ -623,8 +627,8 @@ pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2));
             | _ -> [] *) in
           let unif_from_stack t1 t2 b metasenv subst =
               try
-                let t1 = NCicReduction.from_stack t1 in
-                let t2 = NCicReduction.from_stack t2 in
+                let t1 = NCicReduction.from_stack ~delta:max_int t1 in
+                let t2 = NCicReduction.from_stack ~delta:max_int t2 in
                 unif_machines metasenv subst (put_in_whd t1 t2)
               with UnificationFailure _ | Uncertain _ when not b ->
                 metasenv, subst
@@ -669,10 +673,28 @@ pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2));
           | UnificationFailure _ -> raise (UnificationFailure msg)
           | Uncertain _ -> raise exn
  (*D*)  in outside(); rc with exn -> outside (); raise exn 
+
+and delift_type_wrt_terms rdb metasenv subst context t args =
+  let (metasenv, subst), t =
+   try
+    NCicMetaSubst.delift 
+      ~unify:(fun m s c t1 t2 -> 
+         let ind = !indent in
+         let res = 
+           try Some (unify rdb false m s c t1 t2 )
+           with UnificationFailure _ | Uncertain _ -> None
+         in
+         indent := ind; res)
+      metasenv subst context 0 (0,NCic.Ctx (args @ 
+        List.rev (mk_irl (List.length context)))) t
+   with NCicMetaSubst.MetaSubstFailure _ -> (metasenv, subst), t
+  in
+   metasenv, subst, t
 ;;
 
+
 let unify rdb ?(test_eq_only=false) = 
   indent := "";      
   unify rdb test_eq_only;;
 
-let fix_sorts = fix_sorts false (UnificationFailure (lazy "no sup"));;
+let fix_sorts = fix_sorts true (UnificationFailure (lazy "no sup"));;