X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fcic_unification%2FcicRefine.ml;h=b535b9ebe987677505d7d9b40a2c59731a4c2606;hb=f9abd21eb0d26cf9b632af4df819225be4d091e3;hp=fe5ee7fe378942f14c08ebe923a7a689698af4b4;hpb=154cbc049da8d8c3dd090a919a40c90eb23cc24e;p=helm.git diff --git a/helm/software/components/cic_unification/cicRefine.ml b/helm/software/components/cic_unification/cicRefine.ml index fe5ee7fe3..b535b9ebe 100644 --- a/helm/software/components/cic_unification/cicRefine.ml +++ b/helm/software/components/cic_unification/cicRefine.ml @@ -131,6 +131,20 @@ let exp_impl metasenv subst context = | _ -> assert false ;; +let unvariant newt = + match newt with + | Cic.Appl (hd::args) -> + let uri = CicUtil.uri_of_term hd in + (match + CicEnvironment.get_obj CicUniv.oblivion_ugraph uri + with + | Cic.Constant (_,Some t,_,[],attrs),_ + when List.exists ((=) (`Flavour `Variant)) attrs -> + Cic.Appl (t::args) + | _ -> newt) + | _ -> newt +;; + let is_a_double_coercion t = let rec subst_nth n x l = match n,l with @@ -323,8 +337,8 @@ and check_branch n context metasenv subst left_args_no actualtype term expectedt | _ -> raise (AssertFailure (lazy "Wrong number of arguments"))) | _ -> raise (AssertFailure (lazy "Prod or MutInd expected")) -and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.CicHash.create 1) metasenv context t - ugraph +and type_of_aux' ?(clean_dummy_dependent_types=true) + ?(localization_tbl = Cic.CicHash.create 1) metasenv subst context t ugraph = let rec type_of_aux subst metasenv context t ugraph = let module C = Cic in @@ -406,7 +420,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci type_of_aux subst' metasenv' context te ugraph1 in let rec count_prods context ty = - match CicReduction.whd context ty with + match CicReduction.whd context ~subst:subst'' ty with | Cic.Prod (n,s,t) -> 1 + count_prods (Some (n,Cic.Decl s)::context) t | _ -> 0 @@ -417,7 +431,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci let rec aux t m s ug it = function | 0 -> t,it,m,s,ug | n -> - match CicReduction.whd context it with + match CicReduction.whd context ~subst:s it with | Cic.Prod (_,src,tgt) -> let newmeta, metaty, s, m, ug = type_of_aux s m context (Cic.Implicit None) ug @@ -425,7 +439,6 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci let s,m,ug = fo_unif_subst s context m metaty src ug in -(* prerr_endline "saturo"; *) let t = match t with | Cic.Appl l -> Cic.Appl (l @ [newmeta]) @@ -437,7 +450,6 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci aux te' metasenv'' subst'' ugraph2 inferredty (max 0 (inf_prods - exp_prods)) in -(* prerr_endline ("ottengo: " ^ CicPp.ppterm te'); *) let (te', ty'), subst''',metasenv''',ugraph3 = coerce_to_something true localization_tbl te' inferredty ty' subst'' metasenv'' context ugraph2 @@ -493,7 +505,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci exn -> enrich localization_tbl s' exn ~f:(function _ -> - lazy ("The term " ^ + lazy ("(2) The term " ^ CicMetaSubst.ppterm_in_context ~metasenv:metasenv' subst' s' context ^ " has type " ^ CicMetaSubst.ppterm_in_context ~metasenv:metasenv' subst' ty' @@ -619,7 +631,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci exn -> enrich localization_tbl term' exn ~f:(function _ -> - lazy ("The term " ^ + lazy ("(3) The term " ^ CicMetaSubst.ppterm_in_context ~metasenv subst term' context ^ " has type " ^ CicMetaSubst.ppterm_in_context ~metasenv subst actual_type @@ -665,7 +677,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci exn -> enrich localization_tbl constructor' ~f:(fun _ -> - lazy ("The term " ^ + lazy ("(4) The term " ^ CicMetaSubst.ppterm_in_context metasenv subst p' context ^ " has type " ^ CicMetaSubst.ppterm_in_context metasenv subst actual_type @@ -853,7 +865,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci exn -> enrich localization_tbl p exn ~f:(function _ -> - lazy ("The term " ^ + lazy ("(5) The term " ^ CicMetaSubst.ppterm_in_context ~metasenv subst p context ^ " has type " ^ CicMetaSubst.ppterm_in_context ~metasenv subst instance' @@ -894,7 +906,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci exn -> enrich localization_tbl bo exn ~f:(function _ -> - lazy ("The term " ^ + lazy ("(7) The term " ^ CicMetaSubst.ppterm_in_context ~metasenv subst bo context' ^ " has type " ^ CicMetaSubst.ppterm_in_context ~metasenv subst ty_of_bo @@ -947,7 +959,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci exn -> enrich localization_tbl bo exn ~f:(function _ -> - lazy ("The term " ^ + lazy ("(8) The term " ^ CicMetaSubst.ppterm_in_context ~metasenv subst bo context' ^ " has type " ^ CicMetaSubst.ppterm_in_context ~metasenv subst ty_of_bo @@ -1193,12 +1205,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci | CoercGraph.SomeCoercion candidates -> let selected = HExtlib.list_findopt - (function (metasenv,last,c) -> - match c with - | c when not (CoercGraph.is_composite c) -> - debug_print (lazy ("\nNot a composite.."^CicPp.ppterm c)); - None - | c -> + (fun (metasenv,last,c) _ -> let subst,metasenv,ugraph = fo_unif_subst subst context metasenv last head ugraph in debug_print (lazy ("\nprovo" ^ CicPp.ppterm c)); @@ -1307,7 +1314,8 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci ugraph in debug_print (lazy (" has type: "^ pp tty)); - Some (coerc,tty,subst,metasenv,ugraph) + + Some (unvariant coerc,tty,subst,metasenv,ugraph) with | Uncertain _ | RefineFailure _ | HExtlib.Localized (_,Uncertain _) @@ -1347,7 +1355,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci ugraph in match HExtlib.list_findopt - (fun (he,hetype,subst,metasenv,ugraph) -> + (fun (he,hetype,subst,metasenv,ugraph) _ -> (* {{{ *)debug_print (lazy ("Try fix: "^ CicMetaSubst.ppterm_in_context ~metasenv subst he context)); debug_print (lazy (" of type: "^ @@ -1446,11 +1454,21 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci let newt,newhety,subst,metasenv,ugraph = type_of_aux subst metasenv context c ugraph in let newt, newty, subst, metasenv, ugraph = - avoid_double_coercion context subst metasenv ugraph newt expty + avoid_double_coercion context subst metasenv ugraph newt + expty in let subst,metasenv,ugraph = - fo_unif_subst subst context metasenv newhety expty ugraph in - Some ((newt,newty), subst, metasenv, ugraph) + fo_unif_subst subst context metasenv newhety expty ugraph + in + let b, ugraph = + CicReduction.are_convertible + ~subst ~metasenv context infty expty ugraph + in + if b then + Some ((t,infty), subst, metasenv, ugraph) + else + let newt = unvariant newt in + Some ((newt,newty), subst, metasenv, ugraph) with | Uncertain _ -> uncertain := true; None | RefineFailure _ -> None) @@ -1772,7 +1790,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci coerce_to_something_aux t infty expty subst metasenv context ugraph with Uncertain _ | RefineFailure _ as exn -> let f _ = - lazy ("The term " ^ + lazy ("(9) The term " ^ CicMetaSubst.ppterm_in_context metasenv subst t context ^ " has type " ^ CicMetaSubst.ppterm_in_context metasenv subst infty context ^ " but is here used with type " ^ @@ -1810,7 +1828,7 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci (* eat prods ends here! *) let t',ty,subst',metasenv',ugraph1 = - type_of_aux [] metasenv context t ugraph + type_of_aux subst metasenv context t ugraph in let substituted_t = CicMetaSubst.apply_subst subst' t' in let substituted_ty = CicMetaSubst.apply_subst subst' ty in @@ -1854,7 +1872,21 @@ and type_of_aux' ?(clean_dummy_dependent_types=true) ?(localization_tbl = Cic.Ci else substituted_metasenv in - (cleaned_t,cleaned_ty,cleaned_metasenv,ugraph1) + (cleaned_t,cleaned_ty,cleaned_metasenv,subst',ugraph1) +;; + +let type_of metasenv subst context t ug = + type_of_aux' metasenv subst context t ug +;; + +let type_of_aux' + ?clean_dummy_dependent_types ?localization_tbl metasenv context t ug += + let t,ty,m,s,ug = + type_of_aux' ?clean_dummy_dependent_types ?localization_tbl + metasenv [] context t ug + in + t,ty,m,ug ;; let undebrujin uri typesno tys t = @@ -1955,7 +1987,7 @@ let typecheck metasenv uri obj ~localization_tbl = RefineFailure _ | Uncertain _ as exn -> let msg = - lazy ("The term " ^ + lazy ("(1) The term " ^ CicMetaSubst.ppterm_in_context ~metasenv [] bo' [] ^ " has type " ^ CicMetaSubst.ppterm_in_context ~metasenv [] boty [] ^ @@ -1975,10 +2007,13 @@ let typecheck metasenv uri obj ~localization_tbl = let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in Cic.Constant (name,Some bo',ty',args,attrs),metasenv,ugraph | Cic.Constant (name,None,ty,args,attrs) -> - let ty',_,metasenv,ugraph = + let ty',sort,metasenv,ugraph = type_of_aux' ~localization_tbl metasenv [] ty ugraph in - Cic.Constant (name,None,ty',args,attrs),metasenv,ugraph + (match CicReduction.whd [] sort with + Cic.Sort _ + | Cic.Meta _ -> Cic.Constant (name,None,ty',args,attrs),metasenv,ugraph + | _ -> raise (RefineFailure (lazy ""))) | Cic.CurrentProof (name,metasenv',bo,ty,args,attrs) -> assert (metasenv' = metasenv); (* Here we do not check the metasenv for correctness *) @@ -1987,7 +2022,7 @@ let typecheck metasenv uri obj ~localization_tbl = let ty',sort,metasenv,ugraph = type_of_aux' ~localization_tbl metasenv [] ty ugraph in begin - match sort with + match CicReduction.whd ~delta:true [] sort with Cic.Sort _ (* instead of raising Uncertain, let's hope that the meta will become a sort *)