Metavariable case in does_not_occur (hence weakly/stricly, positive, etc.)

[helm.git] / helm / software / components / ng_kernel / nCicTypeChecker.ml

diff --git a/helm/software/components/ng_kernel/nCicTypeChecker.ml b/helm/software/components/ng_kernel/nCicTypeChecker.ml
index ce16af7d213dc5fbb33f315fdeef49b526689d50..c19561d355821bfffa6fa7fceffeb11ef0a299cd 100644 (file)
--- a/helm/software/components/ng_kernel/nCicTypeChecker.ml
+++ b/helm/software/components/ng_kernel/nCicTypeChecker.ml
@@ -96,13 +96,22 @@ let fixed_args bos j n nn =
    (let rec f = function 0 -> [] | n -> true :: f (n-1) in f j) bos
 ;;
 
-let debruijn uri number_of_types context = 
+let debruijn uri number_of_types ~subst context = 
+(* manca la subst! *)
  let rec aux k t =
   match t with
-   | C.Meta (i,(s,C.Ctx l)) ->
-      let l1 = HExtlib.sharing_map (aux (k-s)) l in
-      if l1 == l then t else C.Meta (i,(s,C.Ctx l1))
-   | C.Meta _ -> t
+   | C.Meta (i,(s,l)) ->
+      (try
+        let _,_,term,_ = U.lookup_subst i subst in
+        let ts = S.subst_meta (0,l) term in
+        let ts' = aux (k-s) ts in
+         if ts == ts' then t else ts'
+       with U.Subst_not_found _ ->
+        match l with
+           C.Ctx l ->
+            let l1 = HExtlib.sharing_map (aux (k-s)) l in
+            if l1 == l then t else C.Meta (i,(s,C.Ctx l1))
+         | _ -> t)
    | C.Const (Ref.Ref (uri1,(Ref.Fix (no,_,_) | Ref.CoFix no))) 
    | C.Const (Ref.Ref (uri1,Ref.Ind (_,no,_))) when NUri.eq uri uri1 ->
       C.Rel (k + number_of_types - no)
@@ -166,7 +175,7 @@ let specialize_and_abstract_constrs ~subst r_uri r_len context ty_term =
     | _ -> assert false
   in
   context_dcl,
-  List.map (fun (_,id,ty) -> id, debruijn r_uri r_len context ty) cl,
+  List.map (fun (_,id,ty) -> id, debruijn r_uri r_len ~subst context ty) cl,
   len, len + r_len
 ;;
 
@@ -188,9 +197,9 @@ let does_not_occur ~subst context n nn t =
                perform substitution only if DoesOccur is raised *)
             let _,_,term,_ = U.lookup_subst mno subst in
             aux (k-s) () (S.subst_meta (0,l) term)
-          with U.Subst_not_found _ -> match l with
+          with U.Subst_not_found _ -> () (*match l with
           | C.Irl len -> if not (n+k >= s+len || s > nn+k) then raise DoesOccur
-          | C.Ctx lc -> List.iter (aux (k-s) ()) lc)
+          | C.Ctx lc -> List.iter (aux (k-s) ()) lc*))
     | t -> U.fold (fun _ k -> k + 1) k aux () t
   in
    try aux 0 () t; true
@@ -261,6 +270,12 @@ let rec weakly_positive ~subst context n nn uri indparamsno posuri te =
   let rec aux context n nn te =
     match R.whd ~subst context te with
      | t when t = dummy -> true
+     | C.Meta (i,lc) ->
+        (try
+          let _,_,term,_ = U.lookup_subst i subst in
+          let t = S.subst_meta lc term in
+           weakly_positive ~subst context n nn uri indparamsno posuri t
+         with U.Subst_not_found _ -> true)
      | C.Appl (te::rargs) when te = dummy ->
         List.for_all (does_not_occur ~subst context n nn) rargs
      | C.Prod (name,source,dest) when
@@ -279,6 +294,12 @@ let rec weakly_positive ~subst context n nn uri indparamsno posuri te =
 and strictly_positive ~subst context n nn indparamsno posuri te =
   match R.whd ~subst context te with
    | t when does_not_occur ~subst context n nn t -> true
+   | C.Meta (i,lc) ->
+      (try
+        let _,_,term,_ = U.lookup_subst i subst in
+        let t = S.subst_meta lc term in
+         strictly_positive ~subst context n nn indparamsno posuri t
+       with U.Subst_not_found _ -> true)
    | C.Rel _ when indparamsno = 0 -> true
    | C.Appl ((C.Rel m)::tl) as reduct when m > n && m <= nn ->
       check_homogeneous_call ~subst context indparamsno n posuri reduct tl;
@@ -695,7 +716,7 @@ and eat_prods ~subst ~metasenv context he ty_he args_with_ty =
 
 and is_non_recursive_singleton ~subst (Ref.Ref (uri,_)) iname ity cty =
      let ctx = [iname, C.Decl ity] in
-     let cty = debruijn uri 1 [] cty in
+     let cty = debruijn uri 1 [] ~subst cty in
      let len = List.length ctx in
      let rec aux ctx n nn t =
        match R.whd ~subst ctx t with
@@ -733,7 +754,7 @@ and check_mutual_inductive_defs uri ~metasenv ~subst leftno tyl =
           let k_relev =
             try snd (HExtlib.split_nth leftno k_relev)
             with Failure _ -> k_relev in
-           let te = debruijn uri len [] te in
+           let te = debruijn uri len [] ~subst te in
            let context,te = NCicReduction.split_prods ~subst tys leftno te in
            let _,chopped_context_rev =
             HExtlib.split_nth (List.length tys) (List.rev context) in
@@ -864,7 +885,7 @@ and guarded_by_destructors r_uri r_len ~subst ~metasenv context recfuns t =
         List.split (List.map (fun (_,name,_,ty,bo) -> (name, C.Decl ty), bo) fl)
       in
       let fl_len = List.length fl in
-      let bos = List.map (debruijn uri fl_len context) bos in
+      let bos = List.map (debruijn uri fl_len context ~subst) bos in
       let j = List.fold_left min max_int (List.map (fun (_,_,i,_,_)->i) fl) in
       let ctx_len = List.length context in
         (* we may look for fixed params not only up to j ... *)
@@ -1204,7 +1225,7 @@ let height_of_term tl =
   1 + !h
 ;;
 
-let height_of_obj_kind uri =
+let height_of_obj_kind uri ~subst =
  function
     NCic.Inductive _
   | NCic.Constant (_,_,None,_,_)
@@ -1214,7 +1235,7 @@ let height_of_obj_kind uri =
       height_of_term
        (List.fold_left
         (fun l (_,_,_,ty,bo) ->
-          let bo = debruijn uri iflno [] bo in
+          let bo = debruijn uri iflno [] ~subst bo in
            ty::bo::l
        ) [] ifl)
   | NCic.Constant (_,_,Some bo,ty,_) -> height_of_term [bo;ty]
@@ -1222,7 +1243,7 @@ let height_of_obj_kind uri =
 
 let typecheck_obj (uri,height,metasenv,subst,kind) =
 (*height must be checked since it is not only an optimization during reduction*)
- let iheight = height_of_obj_kind uri kind in
+ let iheight = height_of_obj_kind uri ~subst kind in
  if height <> iheight then
   raise (TypeCheckerFailure (lazy (Printf.sprintf
    "the declared object height (%d) is not the inferred one (%d)"
@@ -1259,7 +1280,7 @@ let typecheck_obj (uri,height,metasenv,subst,kind) =
       let dfl, kl =   
         List.split (List.map2 
           (fun (_,_,_,_,bo) rno -> 
-             let dbo = debruijn uri len [] bo in
+             let dbo = debruijn uri len [] ~subst bo in
              dbo, Evil rno)
           fl kl)
       in