X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fcic_proof_checking%2FcicTypeChecker.ml;h=5da471a6eb8b934a2239c9994d640925213f91f3;hb=7d7f729471b4d5ebafa1b915096974e726cc13c6;hp=168f6d6aeb091f9e19ac9c1a6ef837efd90b9380;hpb=22ff3a49e742b4289c96d518479a8e08c9192b7c;p=helm.git

diff --git a/helm/ocaml/cic_proof_checking/cicTypeChecker.ml b/helm/ocaml/cic_proof_checking/cicTypeChecker.ml
index 168f6d6ae..5da471a6e 100644
--- a/helm/ocaml/cic_proof_checking/cicTypeChecker.ml
+++ b/helm/ocaml/cic_proof_checking/cicTypeChecker.ml
@@ -52,10 +52,11 @@ let rec split l n =
       raise (TypeCheckerFailure (lazy "Parameters number < left parameters number"))
 ;;
 
-let debrujin_constructor uri number_of_types =
- let rec aux k =
+let debrujin_constructor ?(cb=fun _ _ -> ()) uri number_of_types =
+ let rec aux k t =
   let module C = Cic in
-   function
+  let res =
+   match t with
       C.Rel n as t when n <= k -> t
     | C.Rel _ ->
         raise (TypeCheckerFailure (lazy "unbound variable found in constructor type"))
@@ -66,7 +67,7 @@ let debrujin_constructor uri number_of_types =
         C.Var (uri,exp_named_subst')
     | C.Meta (i,l) ->
        let l' = List.map (function None -> None | Some t -> Some (aux k t)) l in
-        C.Meta (i,l)
+        C.Meta (i,l')
     | C.Sort _
     | C.Implicit _ as t -> t
     | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty)
@@ -114,6 +115,9 @@ let debrujin_constructor uri number_of_types =
           fl
        in
         C.CoFix (i, liftedfl)
+  in
+   cb t res;
+   res
  in
   aux 0
 ;;
@@ -545,7 +549,7 @@ and typecheck_mutual_inductive_defs ~logger uri (itl,_,indparamsno) ugraph =
 		ugraph'
             ) ugraph cl in
 	(i + 1),ugraph''
-      ) itl (1,ugraph)
+      ) itl (1,ugrap1)
   in
   ugraph2
 
@@ -1126,11 +1130,10 @@ and guarded_by_constructors ~subst context n nn h te args coInductiveTypeURI =
          | C.Lambda _
          | C.LetIn _ ->
             raise (AssertFailure (lazy "25"))(* due to type-checking *)
-         | C.Appl ((C.MutInd (uri,_,_))::_) as ty
-            when uri == coInductiveTypeURI -> 
+         | C.Appl ((C.MutInd (uri,_,_))::_) when uri == coInductiveTypeURI -> 
              guarded_by_constructors ~subst context n nn true te []
               coInductiveTypeURI
-         | C.Appl ((C.MutInd (uri,_,_))::_) as ty -> 
+         | C.Appl ((C.MutInd (uri,_,_))::_) -> 
             guarded_by_constructors ~subst context n nn true te tl
              coInductiveTypeURI
          | C.Appl _ ->
@@ -1302,14 +1305,24 @@ and check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i
    | (C.Sort C.Prop, C.Sort C.Set)
    | (C.Sort C.Prop, C.Sort C.CProp)
    | (C.Sort C.Prop, C.Sort (C.Type _) ) when need_dummy ->
-   (* TASSI: da verificare *)
-(*CSC: WRONG. MISSING CONDITIONS ON THE ARGUMENTS OF THE CONSTRUTOR *)
        (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
 	 match o with
-         C.InductiveDefinition (itl,_,_,_) ->
-           let (_,_,_,cl) = List.nth itl i in
-           (* is a singleton definition or the empty proposition? *)
-           (List.length cl = 1 || List.length cl = 0) , ugraph
+         C.InductiveDefinition (itl,_,paramsno,_) ->
+           let itl_len = List.length itl in
+           let (name,_,ty,cl) = List.nth itl i in
+           let cl_len = List.length cl in
+            if (cl_len = 0 || (itl_len = 1 && cl_len = 1)) then
+             let non_informative,ugraph =
+              if cl_len = 0 then true,ugraph
+              else
+               is_non_informative ~logger [Some (C.Name name,C.Decl ty)]
+                paramsno (snd (List.nth cl 0)) ugraph
+             in
+              (* is it a singleton or empty non recursive and non informative
+                 definition? *)
+              non_informative, ugraph
+            else
+              false,ugraph
          | _ ->
              raise (TypeCheckerFailure 
 		     (lazy ("Unknown mutual inductive definition:" ^
@@ -1322,7 +1335,6 @@ and check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i
    | (C.Sort C.CProp, C.Sort C.Set) when need_dummy -> true , ugraph
    | (C.Sort C.CProp, C.Sort C.CProp) when need_dummy -> true , ugraph
    | ((C.Sort C.Set, C.Sort (C.Type _)) | (C.Sort C.CProp, C.Sort (C.Type _)))
-      (* TASSI: da verificare *)
       when need_dummy ->
        (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
 	 match o with
@@ -1344,7 +1356,6 @@ and check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i
               UriManager.string_of_uri uri)))
        )
    | (C.Sort (C.Type _), C.Sort _) when need_dummy -> true , ugraph
-     (* TASSI: da verificare *)
    | (_,_) -> false,ugraph
  in
   check_allowed_sort_elimination_aux ugraph context arity2 need_dummy
@@ -1679,8 +1690,7 @@ and type_of_aux' ~logger ?(subst = []) metasenv context t ugraph =
 		  (lazy (sprintf
 		      ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}")
 		      (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i)))
-          | C.Appl 
-	      ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) as typ' ->
+          | C.Appl ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) ->
               if U.eq uri uri' && i = i' then
 		let params,args =
 		  split tl (List.length tl - k)
@@ -2000,21 +2010,32 @@ in debug_print (lazy "FINE TYPE_OF_AUX") ; flush stderr ; res
 
 (* is a small constructor? *)
 (*CSC: ottimizzare calcolando staticamente *)
-and is_small ~logger context paramsno c ugraph =
- let rec is_small_aux ~logger context c ugraph =
+and is_small_or_non_informative ~condition ~logger context paramsno c ugraph =
+ let rec is_small_or_non_informative_aux ~logger context c ugraph =
   let module C = Cic in
    match CicReduction.whd context c with
       C.Prod (n,so,de) ->
        let s,ugraph1 = type_of_aux' ~logger [] context so ugraph in
-       let b = (s = C.Sort C.Prop || s = C.Sort C.Set || s = C.Sort C.CProp) in
+       let b = condition s in
        if b then
-         is_small_aux ~logger ((Some (n,(C.Decl so)))::context) de ugraph1
+         is_small_or_non_informative_aux
+          ~logger ((Some (n,(C.Decl so)))::context) de ugraph1
        else 
        	 false,ugraph1
     | _ -> true,ugraph (*CSC: we trust the type-checker *)
  in
   let (context',dx) = split_prods ~subst:[] context paramsno c in
-   is_small_aux ~logger context' dx ugraph
+   is_small_or_non_informative_aux ~logger context' dx ugraph
+
+and is_small ~logger =
+ is_small_or_non_informative
+  ~condition:(fun s -> s=Cic.Sort Cic.Prop || s=Cic.Sort Cic.Set)
+  ~logger
+
+and is_non_informative ~logger =
+ is_small_or_non_informative
+  ~condition:(fun s -> s=Cic.Sort Cic.Prop)
+  ~logger
 
 and type_of ~logger t ugraph =
 (*CSC
@@ -2129,3 +2150,16 @@ let typecheck_obj uri obj =
  let logger = new CicLogger.logger in
  typecheck_obj ~logger uri obj
 
+(* check_allowed_sort_elimination uri i s1 s2
+   This function is used outside the kernel to determine in advance whether
+   a MutCase will be allowed or not.
+   [uri,i] is the type of the term to match
+   [s1] is the sort of the term to eliminate (i.e. the head of the arity
+        of the inductive type [uri,i])
+   [s2] is the sort of the goal (i.e. the head of the type of the outtype
+        of the MutCase) *)
+let check_allowed_sort_elimination uri i s1 s2 =
+ fst (check_allowed_sort_elimination ~subst:[] ~metasenv:[]
+  ~logger:(new CicLogger.logger) [] uri i true
+  (Cic.Implicit None) (* never used *) (Cic.Sort s1) (Cic.Sort s2)
+  CicUniv.empty_ugraph)