Don't reinvent the wheel.

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

diff --git a/helm/software/components/ng_refiner/nCicRefiner.ml b/helm/software/components/ng_refiner/nCicRefiner.ml
index 0f835961eeaef5353edd1eafa6110b8ee47e234f..a227e918e1d467d40809f6f1a2a2a116cd6a4d65 100644 (file)
--- a/helm/software/components/ng_refiner/nCicRefiner.ml
+++ b/helm/software/components/ng_refiner/nCicRefiner.ml
@@ -36,16 +36,18 @@ let wrap_exc msg = function
   | e -> raise e
 ;;
 
-let exp_implicit metasenv context expty =
+let exp_implicit ~localise metasenv context expty t =
  let foo x = match expty with Some t -> `WithType t | None -> x in
  function      
   | `Closed -> NCicMetaSubst.mk_meta metasenv [] (foo `Term)
   | `Type -> NCicMetaSubst.mk_meta metasenv context (foo `Type)
   | `Term -> NCicMetaSubst.mk_meta metasenv context (foo `Term)
+  | `Vector ->
+      raise (RefineFailure (lazy (localise t, "A vector of implicit terms " ^
+       "can only be used in argument position")))
   | _ -> assert false
 ;;
 
-
 let check_allowed_sort_elimination rdb localise r orig =
    let mkapp he arg =
      match he with
@@ -145,8 +147,10 @@ let rec typeof rdb
           NCicPp.ppterm ~subst ~metasenv ~context t)))
     | C.Sort _ -> metasenv,subst,t,(C.Sort (C.Type NCicEnvironment.type0))
     | C.Implicit infos -> 
-         let metasenv,_,t,ty = exp_implicit metasenv context expty infos in
-         metasenv, subst, t, ty 
+         let metasenv,_,t,ty =
+           exp_implicit ~localise metasenv context expty t infos
+         in
+          metasenv, subst, t, ty 
     | C.Meta (n,l) as t -> 
        let ty =
         try
@@ -228,15 +232,11 @@ let rec typeof rdb
        let bo_ty = NCicSubstitution.subst ~avoid_beta_redexes:true t bo_ty in
        metasenv, subst, C.LetIn (n, ty, t, bo), bo_ty
     | C.Appl ((he as orig_he)::(_::_ as args)) ->
-       let upto = 
-         match orig_he with C.Meta _ -> List.length args | _ -> 0
-       in
+       let upto = match orig_he with C.Meta _ -> List.length args | _ -> 0 in
        let metasenv, subst, he, ty_he = 
          typeof_aux metasenv subst context None he in
        let metasenv, subst, t, ty = 
-         eat_prods rdb ~localise
-           metasenv subst context orig_he he ty_he args
-       in
+         eat_prods rdb ~localise metasenv subst context orig_he he ty_he args in
        let t = if upto > 0 then NCicReduction.head_beta_reduce ~upto t else t in
        metasenv, subst, t, ty
    | C.Appl _ -> raise (AssertFailure (lazy "Appl of length < 2"))
@@ -376,8 +376,7 @@ and try_coercions rdb
       | NCicUnification.Uncertain _ as exc -> first exc tl
   in 
     first exc
-      (NCicCoercion.look_for_coercion 
-        rdb.NRstatus.coerc_db metasenv subst context infty expty)
+      (NCicCoercion.look_for_coercion rdb metasenv subst context infty expty)
 
 and force_to_sort rdb metasenv subst context t orig_t localise ty =
   match NCicReduction.whd ~subst context ty with
@@ -437,12 +436,11 @@ and guess_name subst ctx ty =
       with NCicUtils.Subst_not_found _ -> aux 'M')
   | _ -> aux 'H' 
 
-and eat_prods rdb
-  ~localise metasenv subst context orig_he he ty_he args 
-=
+and eat_prods rdb ~localise metasenv subst context orig_he he ty_he args =
   (*D*)inside 'E'; try let rc = 
   let rec aux metasenv subst args_so_far he ty_he = function 
-  | []->metasenv, subst, NCicUntrusted.mk_appl he (List.rev args_so_far), ty_he
+  | [] ->metasenv, subst, NCicUntrusted.mk_appl he (List.rev args_so_far), ty_he
+  | NCic.Implicit `Vector::tl -> assert false
   | arg::tl ->
       match NCicReduction.whd ~subst context ty_he with 
       | C.Prod (_,s,t) ->
@@ -559,7 +557,6 @@ let undebruijnate inductive ref t rev_fl =
 let typeof_obj 
   rdb ?(localise=fun _ -> Stdpp.dummy_loc) (uri,height,metasenv,subst,obj)
 = 
-prerr_endline ("===============\n" ^ NCicPp.ppobj (uri,height,metasenv,subst,obj));
   let check_type metasenv subst context (ty as orig_ty) =  (* XXX fattorizza *)
     let metasenv, subst, ty, sort = 
       typeof rdb ~localise metasenv subst context ty None
@@ -576,8 +573,7 @@ prerr_endline ("===============\n" ^ NCicPp.ppobj (uri,height,metasenv,subst,obj
          match bo with
          | Some bo ->
              let metasenv, subst, bo, ty = 
-               typeof rdb ~localise metasenv subst [] bo (Some ty)
-             in
+               typeof rdb ~localise metasenv subst [] bo (Some ty) in
              let height = (* XXX recalculate *) height in
                metasenv, subst, Some bo, ty, height
          | None -> metasenv, subst, None, ty, 0
@@ -590,7 +586,7 @@ prerr_endline ("===============\n" ^ NCicPp.ppobj (uri,height,metasenv,subst,obj
         List.fold_left
          (fun (types, metasenv, subst, fl) (relevance,name,k,ty,bo) ->
            let metasenv, subst, ty, _ = check_type metasenv subst [] ty in
-           let dbo = NCicTypeChecker.debruijn uri len [] bo in
+           let dbo = NCicTypeChecker.debruijn uri len [] ~subst bo in
            let localise = relocalise localise dbo bo in
             (name,C.Decl ty)::types,
               metasenv, subst, (relevance,name,k,ty,dbo,localise)::fl
@@ -639,7 +635,7 @@ prerr_endline ("===============\n" ^ NCicPp.ppobj (uri,height,metasenv,subst,obj
             let k_relev =
               try snd (HExtlib.split_nth leftno k_relev)
               with Failure _ -> k_relev in
-             let te = NCicTypeChecker.debruijn uri len [] te in
+             let te = NCicTypeChecker.debruijn uri len [] ~subst te in
              let metasenv, subst, te, _ = check_type metasenv subst tys te in
              let context,te = NCicReduction.split_prods ~subst tys leftno te in
              let _,chopped_context_rev =
@@ -717,7 +713,8 @@ prerr_endline ("===============\n" ^ NCicPp.ppobj (uri,height,metasenv,subst,obj
                 raise
                   (RefineFailure
                     (lazy (localise te,
-                      "Non positive occurence in " ^ NUri.string_of_uri uri)))
+                      "Non positive occurence in " ^
+                        NCicPp.ppterm ~metasenv ~subst ~context te)))
               else
                let relsno = List.length itl + leftno in
                let te = 
@@ -747,4 +744,6 @@ prerr_endline ("===============\n" ^ NCicPp.ppobj (uri,height,metasenv,subst,obj
       uri, height, metasenv, subst, C.Inductive (ind, leftno, itl, attr)
 ;;
 
+NCicUnification.set_refiner_typeof typeof;;
+
 (* vim:set foldmethod=marker: *)