X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fcic_unification%2FcicRefine.ml;h=9434f523235931389762cd1f3252f61308f9e69c;hb=7cb90c67bc6f8113188a91ecc29f6db20db5aeb8;hp=881c72bfd516852218105dc56ce71653219ce4d8;hpb=265cf771fbfe217b5f274b999fc3ad887683a09a;p=helm.git

diff --git a/helm/ocaml/cic_unification/cicRefine.ml b/helm/ocaml/cic_unification/cicRefine.ml
index 881c72bfd..9434f5232 100644
--- a/helm/ocaml/cic_unification/cicRefine.ml
+++ b/helm/ocaml/cic_unification/cicRefine.ml
@@ -28,11 +28,13 @@ exception NotRefinable of string;;
 exception Uncertain of string;;
 exception WrongUriToConstant of string;;
 exception WrongUriToVariable of string;;
+exception ListTooShort;;
 exception WrongUriToMutualInductiveDefinitions of string;;
 exception RelToHiddenHypothesis;;
 exception MetasenvInconsistency;;
 exception MutCaseFixAndCofixRefineNotImplemented;;
 exception FreeMetaFound of int;;
+exception WrongArgumentNumber;;
 
 let fdebug = ref 0;;
 let debug t context =
@@ -46,6 +48,15 @@ let debug t context =
    (*print_endline ("\n" ^ List.fold_right debug_aux (t::context) "") ; flush stdout*)
 ;;
 
+let debug_print = prerr_endline
+
+let rec split l n =
+ match (l,n) with
+    (l,0) -> ([], l)
+  | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2)
+  | (_,_) -> raise ListTooShort
+;;
+
 let rec type_of_constant uri =
  let module C = Cic in
  let module R = CicReduction in
@@ -85,6 +96,42 @@ and type_of_mutual_inductive_constr uri i j =
    | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
 
 (* type_of_aux' is just another name (with a different scope) for type_of_aux *)
+
+(* the check_branch function checks if a branch of a case is refinable. 
+   It returns a pair (outype_instance,args), a subst and a metasenv.
+   outype_instance is the expected result of applying the case outtype 
+   to args. 
+   The problem is that outype is in general unknown, and we should
+   try to synthesize it from the above information, that is in general
+   a second order unification problem. *)
+ 
+and check_branch n context metasenv subst left_args_no actualtype term expectedtype =
+  let module C = Cic in
+  let module R = CicMetaSubst in
+  let module Un = CicUnification in 
+  match R.whd subst context expectedtype with
+     C.MutInd (_,_,_) ->
+       (n,context,actualtype, [term]), subst, metasenv
+   | C.Appl (C.MutInd (_,_,_)::tl) ->
+       let (_,arguments) = split tl left_args_no in
+       (n,context,actualtype, arguments@[term]), subst, metasenv
+   | C.Prod (name,so,de) ->
+      (* we expect that the actual type of the branch has the due 
+         number of Prod *)
+      (match R.whd subst context actualtype with
+           C.Prod (name',so',de') ->
+             let subst, metasenv = 
+                Un.fo_unif_subst subst context metasenv so so' in
+             let term' =
+               (match CicSubstitution.lift 1 term with
+                   C.Appl l -> C.Appl (l@[C.Rel 1])
+                 | t -> C.Appl [t ; C.Rel 1]) in
+             (* we should also check that the name variable is anonymous in
+             the actual type de' ?? *)
+             check_branch (n+1) ((Some (name,(C.Decl so)))::context) metasenv subst left_args_no de' term' de 
+	 | _ -> raise WrongArgumentNumber)
+  | _ -> raise (NotRefinable "Prod or MutInd expected")
+
 and type_of_aux' metasenv context t =
  let rec type_of_aux subst metasenv context =
   let module C = Cic in
@@ -98,7 +145,6 @@ and type_of_aux' metasenv context t =
             Some (_,C.Decl t) -> S.lift n t,subst,metasenv
           | Some (_,C.Def (_,Some ty)) -> S.lift n ty,subst,metasenv
           | Some (_,C.Def (bo,None)) ->
-             prerr_endline "##### DA INVESTIGARE E CAPIRE" ;
              type_of_aux subst metasenv context (S.lift n bo)
 	  | None -> raise RelToHiddenHypothesis
         with
@@ -209,7 +255,97 @@ and type_of_aux' metasenv context t =
         (type_of_mutual_inductive_constr uri i j)
       in
        cty,subst',metasenv'
-   | C.MutCase _
+   | C.MutCase (uri, i, outtype, term, pl) ->
+       (* first, get the inductive type (and noparams) in the environment  *)
+       let (_,b,arity,constructors), expl_params, no_left_params =
+         match CicEnvironment.get_cooked_obj ~trust:true uri with
+            C.InductiveDefinition (l,expl_params,parsno) -> 
+              List.nth l i , expl_params, parsno
+          | _ ->
+            raise
+             (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) in
+       let rec count_prod t =
+         match CicMetaSubst.whd subst context t with
+             C.Prod (_, _, t) -> 1 + (count_prod t)
+           | _ -> 0 in 
+       let no_args = count_prod arity in
+       (* now, create a "generic" MutInd *)
+       let metasenv,left_args = 
+         CicMkImplicit.n_fresh_metas metasenv context no_left_params in
+       let metasenv,right_args = 
+         let no_right_params = no_args - no_left_params in
+         if no_right_params < 0 then assert false
+         else CicMkImplicit.n_fresh_metas metasenv context no_right_params in
+       let metasenv,exp_named_subst = 
+         CicMkImplicit.fresh_subst metasenv context expl_params in
+       let expected_type = 
+         if no_args = 0 then 
+           C.MutInd (uri,i,exp_named_subst)
+         else
+	   C.Appl (C.MutInd (uri,i,exp_named_subst)::(left_args @ right_args))
+       in
+       (* check consistency with the actual type of term *)
+       let actual_type,subst,metasenv = 
+         type_of_aux subst metasenv context term in
+       let _, subst, metasenv =
+         type_of_aux subst metasenv context expected_type
+       in
+       let actual_type = CicMetaSubst.whd subst context actual_type in
+       let subst,metasenv =
+         Un.fo_unif_subst subst context metasenv expected_type actual_type
+       in
+       (* TODO: check if the sort elimination is allowed: [(I q1 ... qr)|B] *)
+       let (_,outtypeinstances,subst,metasenv) =
+          List.fold_left
+           (fun (j,outtypeinstances,subst,metasenv) p ->
+             let constructor =
+              if left_args = [] then
+               (C.MutConstruct (uri,i,j,exp_named_subst))
+              else
+               (C.Appl (C.MutConstruct (uri,i,j,exp_named_subst)::left_args))
+             in
+             let actual_type,subst,metasenv = 
+               type_of_aux subst metasenv context p in
+             let expected_type, subst, metasenv = 
+               type_of_aux subst metasenv context constructor in
+             let outtypeinstance,subst,metasenv =
+               check_branch 
+                0 context metasenv subst 
+                no_left_params actual_type constructor expected_type in
+             (j+1,outtypeinstance::outtypeinstances,subst,metasenv))
+            (1,[],subst,metasenv) pl in
+        (* we are left to check that the outype matches his instances.
+           The easy case is when the outype is specified, that amount
+           to a trivial check. Otherwise, we should guess a type from
+           its instances *)
+        (* easy case *)
+        let _, subst, metasenv =
+          type_of_aux subst metasenv context
+            (C.Appl ((outtype :: right_args) @ [term]))
+        in
+        let (subst,metasenv) = 
+          List.fold_left
+            (fun (subst,metasenv) (constructor_args_no,context,instance,args) ->
+              let instance' = 
+                let appl =
+                  let outtype' =
+                    CicSubstitution.lift constructor_args_no outtype
+                  in
+                  C.Appl (outtype'::args)
+                in
+(*
+                (* if appl is not well typed then the type_of below solves the
+                 * problem *)
+                let (_, subst, metasenv) =
+                  type_of_aux subst metasenv context appl
+                in
+*)
+                CicMetaSubst.whd subst context appl
+              in
+               Un.fo_unif_subst subst context metasenv instance instance')
+             (subst,metasenv) outtypeinstances in
+        CicMetaSubst.whd subst
+          context (C.Appl(outtype::right_args@[term])),subst,metasenv
    | C.Fix _
    | C.CoFix _ -> raise MutCaseFixAndCofixRefineNotImplemented
 
@@ -236,7 +372,8 @@ and type_of_aux' metasenv context t =
      List.fold_left2 
       (fun (subst,metasenv) t ct -> 
         match (t,ct) with
-           _,None -> subst,metasenv
+           _,None ->
+             subst,metasenv
          | Some t,Some (_,C.Def (ct,_)) ->
             (try
               CicUnification.fo_unif_subst subst context metasenv t ct
@@ -246,9 +383,11 @@ and type_of_aux' metasenv context t =
              type_of_aux subst metasenv context t
             in
              (try
-               CicUnification.fo_unif_subst subst context metasenv inferredty ct
+               CicUnification.fo_unif_subst
+                subst' context metasenv' inferredty ct
              with _ -> raise MetasenvInconsistency)
-         | _, _  -> raise MetasenvInconsistency
+         | _, _  ->
+             raise MetasenvInconsistency
       ) (subst,metasenv) l lifted_canonical_context 
 
  and check_exp_named_subst metasubst metasenv context =
@@ -283,24 +422,30 @@ and type_of_aux' metasenv context t =
  and sort_of_prod subst metasenv context (name,s) (t1, t2) =
   let module C = Cic in
    (* ti could be a metavariable in the domain of the substitution *)
-   let subst',metasenv' = CicUnification.unwind_subst metasenv subst in
-   let t1' = CicUnification.apply_subst subst' t1 in
-   let t2' = CicUnification.apply_subst subst' t2 in
-    let t1'' = CicReduction.whd context t1' in
-    let t2'' = CicReduction.whd ((Some (name,C.Decl s))::context) t2' in
+   let subst',metasenv' = CicMetaSubst.unwind_subst metasenv subst in
+   let t1' = CicMetaSubst.apply_subst subst' t1 in
+   let t2' = CicMetaSubst.apply_subst subst' t2 in
+    let t1'' = CicMetaSubst.whd subst' context t1' in
+    let t2'' = CicMetaSubst.whd subst' ((Some (name,C.Decl s))::context) t2' in
     match (t1'', t2'') with
        (C.Sort s1, C.Sort s2)
-         when (s2 = C.Prop or s2 = C.Set) -> (* different from Coq manual!!! *)
+         when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) -> (* different from Coq manual!!! *)
           C.Sort s2,subst',metasenv'
      | (C.Sort s1, C.Sort s2) ->
          (*CSC manca la gestione degli universi!!! *)
          C.Sort C.Type,subst',metasenv'
-     | (C.Meta _,_)
-     | (_,C.Meta _) ->
+     | (C.Meta _,_) | (_,C.Meta _) ->
+         let (metasenv', idx) = CicMkImplicit.mk_implicit metasenv context in
+         let irl =
+           CicMkImplicit.identity_relocation_list_for_metavariable context
+         in
+         C.Meta (idx, irl), subst, metasenv'
+(*
        raise
         (Uncertain
           ("Two sorts were expected, found " ^ CicPp.ppterm t1'' ^ " and " ^
            CicPp.ppterm t2''))
+*)
      | (_,_) ->
        raise
         (NotRefinable
@@ -310,13 +455,10 @@ and type_of_aux' metasenv context t =
   function
      [] -> hetype,subst,metasenv
    | (hete, hety)::tl ->
-    (match (CicReduction.whd context hetype) with
+    (match (CicMetaSubst.whd subst context hetype) with
         Cic.Prod (n,s,t) ->
          let subst',metasenv' =
-          try
            CicUnification.fo_unif_subst subst context metasenv s hety
-          with _ ->
-           raise (NotRefinable "Appl: wrong parameter-type")
          in
           CicReduction.fdebug := -1 ;
           eat_prods subst' metasenv' context (CicSubstitution.subst hete t) tl
@@ -330,39 +472,50 @@ and type_of_aux' metasenv context t =
   let ty,subst',metasenv' =
    type_of_aux [] metasenv context t
   in
-   let subst'',metasenv'' = CicUnification.unwind_subst metasenv' subst' in
+   let subst'',metasenv'' = CicMetaSubst.unwind_subst metasenv' subst' in
    (* we get rid of the metavariables that have been instantiated *)
    let metasenv''' =
     List.filter
      (function (i,_,_) -> not (List.exists (function (j,_) -> j=i) subst''))
      metasenv''
    in
-    CicUnification.apply_subst subst'' t,
-     CicUnification.apply_subst subst'' ty,
-     subst'', metasenv'''
+    CicMetaSubst.apply_subst subst'' t,
+     CicMetaSubst.apply_subst subst'' ty,
+      subst'', metasenv'''
 ;;
 
 (* DEBUGGING ONLY *)
 let type_of_aux' metasenv context term =
  try
-  let (t,ty,s,m) =
-   type_of_aux' metasenv context term
-  in
+  let (t,ty,s,m) = type_of_aux' metasenv context term in
+(*
    List.iter
     (function (i,t) ->
-      prerr_endline ("+ ?" ^ string_of_int i ^ " := " ^ CicPp.ppterm t)) s ;
+      debug_print ("+ ?" ^ string_of_int i ^ " := " ^ CicPp.ppterm t)) s ;
    List.iter
     (function (i,_,t) ->
-      prerr_endline ("+ ?" ^ string_of_int i ^ " : " ^ CicPp.ppterm t)) m ;
-   prerr_endline
+      debug_print ("+ ?" ^ string_of_int i ^ " : " ^ CicPp.ppterm t)) m ;
+*)
+   debug_print
     ("@@@ REFINE SUCCESSFUL: " ^ CicPp.ppterm t ^ " : " ^ CicPp.ppterm ty) ;
    (t,ty,s,m)
  with
-  e ->
+ | CicUnification.AssertFailure msg as e ->
+     debug_print "@@@ REFINE FAILED: CicUnification.AssertFailure:";
+     debug_print msg;
+     raise e
+ | CicUnification.UnificationFailure msg as e ->
+     debug_print "@@@ REFINE FAILED: CicUnification.UnificationFailure:";
+     debug_print msg;
+     raise e
+ | e ->
+(*
    List.iter
     (function (i,_,t) ->
-      prerr_endline ("+ ?" ^ string_of_int i ^ " : " ^ CicPp.ppterm t))
+      debug_print ("+ ?" ^ string_of_int i ^ " : " ^ CicPp.ppterm t))
     metasenv ;
-   prerr_endline ("@@@ REFINE FAILED: " ^ Printexc.to_string e) ;
+*)
+   debug_print ("@@@ REFINE FAILED: " ^ Printexc.to_string e) ;
    raise e
 ;;
+