diff options
Diffstat (limited to 'tactics')
35 files changed, 2607 insertions, 1444 deletions
diff --git a/tactics/auto.ml b/tactics/auto.ml index 152556c74a..0f296c6af0 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -36,16 +36,17 @@ open Tacexpr open Mod_subst open Locus open Proofview.Notations +open Decl_kinds (****************************************************************************) (* The Type of Constructions Autotactic Hints *) (****************************************************************************) type 'a auto_tactic = - | Res_pf of constr * 'a (* Hint Apply *) - | ERes_pf of constr * 'a (* Hint EApply *) - | Give_exact of constr - | Res_pf_THEN_trivial_fail of constr * 'a (* Hint Immediate *) + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of glob_tactic_expr (* Hint Extern *) @@ -61,16 +62,22 @@ type hints_path = | PathEmpty | PathEpsilon +type hint_term = + | IsGlobRef of global_reference + | IsConstr of constr * Univ.universe_context_set + type 'a gen_auto_tactic = { pri : int; (* A number lower is higher priority *) + poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) name : hints_path_atom; (* A potential name to refer to the hint *) code : 'a auto_tactic (* the tactic to apply when the concl matches pat *) } -type pri_auto_tactic = clausenv gen_auto_tactic +type pri_auto_tactic = (constr * clausenv) gen_auto_tactic -type hint_entry = global_reference option * types gen_auto_tactic +type hint_entry = global_reference option * + (constr * types * Univ.universe_context_set) gen_auto_tactic let eq_hints_path_atom p1 p2 = match p1, p2 with | PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2 @@ -80,7 +87,7 @@ let eq_hints_path_atom p1 p2 = match p1, p2 with let eq_auto_tactic t1 t2 = match t1, t2 with | Res_pf (c1, _), Res_pf (c2, _) -> Constr.equal c1 c2 | ERes_pf (c1, _), ERes_pf (c2, _) -> Constr.equal c1 c2 -| Give_exact c1, Give_exact c2 -> Constr.equal c1 c2 +| Give_exact (c1, _), Give_exact (c2, _) -> Constr.equal c1 c2 | Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> Constr.equal c1 c2 | Unfold_nth gr1, Unfold_nth gr2 -> eq_egr gr1 gr2 | Extern tac1, Extern tac2 -> tac1 == tac2 (** May cause redundancy in addkv *) @@ -134,17 +141,23 @@ type search_entry = stored_data list * stored_data list * Bounded_net.t let empty_se = ([],[],Bounded_net.create ()) +let eq_constr_or_reference x y = + match x, y with + | IsConstr (x,_), IsConstr (y,_) -> eq_constr x y + | IsGlobRef x, IsGlobRef y -> eq_gr x y + | _, _ -> false + let eq_pri_auto_tactic (_, x) (_, y) = if Int.equal x.pri y.pri && Option.equal constr_pattern_eq x.pat y.pat then match x.code,y.code with - | Res_pf(cstr,_),Res_pf(cstr1,_) -> + | Res_pf (cstr,_),Res_pf (cstr1,_) -> eq_constr cstr cstr1 - | ERes_pf(cstr,_),ERes_pf(cstr1,_) -> + | ERes_pf (cstr,_),ERes_pf (cstr1,_) -> eq_constr cstr cstr1 - | Give_exact cstr,Give_exact cstr1 -> + | Give_exact (cstr,_),Give_exact (cstr1,_) -> eq_constr cstr cstr1 - | Res_pf_THEN_trivial_fail(cstr,_) - ,Res_pf_THEN_trivial_fail(cstr1,_) -> + | Res_pf_THEN_trivial_fail (cstr,_) + ,Res_pf_THEN_trivial_fail (cstr1,_) -> eq_constr cstr cstr1 | _,_ -> false else @@ -176,20 +189,44 @@ let is_transparent_gr (ids, csts) = function let dummy_goal = Goal.V82.dummy_goal -let translate_hint (go,p) = - let mk_clenv (c,t) = - let cl = mk_clenv_from dummy_goal (c,t) in {cl with env = empty_env } +let instantiate_constr_or_ref env sigma c = + let c, ctx = Universes.fresh_global_or_constr_instance env c in + let cty = Retyping.get_type_of env sigma c in + (c, cty), ctx + +let strip_params env c = + match kind_of_term c with + | App (f, args) -> + (match kind_of_term f with + | Const (p,_) -> + let cb = lookup_constant p env in + (match cb.Declarations.const_proj with + | Some pb -> + let n = pb.Declarations.proj_npars in + mkApp (mkProj (p, args.(n)), + Array.sub args (n+1) (Array.length args - (n + 1))) + | None -> c) + | _ -> c) + | _ -> c + +let instantiate_hint p = + let mk_clenv c cty ctx = + let sigma = Evd.merge_context_set univ_flexible dummy_goal.sigma ctx in + let goal = { dummy_goal with sigma = sigma } in + let cl = mk_clenv_from goal (c,cty) in + {cl with templval = + { cl.templval with rebus = strip_params (Global.env()) cl.templval.rebus }; + env = empty_env} in let code = match p.code with - | Res_pf (c,t) -> Res_pf (c, mk_clenv (c,t)) - | ERes_pf (c,t) -> ERes_pf (c, mk_clenv (c,t)) - | Res_pf_THEN_trivial_fail (c,t) -> - Res_pf_THEN_trivial_fail (c, mk_clenv (c,t)) - | Give_exact c -> Give_exact c + | Res_pf (c, cty, ctx) -> Res_pf (c, mk_clenv c cty ctx) + | ERes_pf (c, cty, ctx) -> ERes_pf (c, mk_clenv c cty ctx) + | Res_pf_THEN_trivial_fail (c, cty, ctx) -> + Res_pf_THEN_trivial_fail (c, mk_clenv c cty ctx) + | Give_exact (c, cty, ctx) -> Give_exact (c, mk_clenv c cty ctx) | Unfold_nth e -> Unfold_nth e | Extern t -> Extern t - in - (go,{ p with code = code }) + in { pri = p.pri; poly = p.poly; name = p.name; pat = p.pat; code = code } let hints_path_atom_eq h1 h2 = match h1, h2 with | PathHints l1, PathHints l2 -> List.equal eq_gr l1 l2 @@ -350,17 +387,19 @@ module Hint_db = struct try Constr_map.find key db.hintdb_map with Not_found -> empty_se + let realize_tac (id,tac) = tac + let map_none db = - List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat) []) + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) []) let map_all k db = let (l,l',_) = find k db in - List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat @ l) l') + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l') let map_auto (k,c) db = let st = if db.use_dn then Some db.hintdb_state else None in let l' = lookup_tacs (k,c) st (find k db) in - List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat) l') + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l') let is_exact = function | Give_exact _ -> true @@ -384,6 +423,7 @@ module Hint_db = struct (** ppedrot: this equality here is dubious. Maybe we can remove it? *) let is_present (_, (_, v')) = eq_gen_auto_tactic v v' in if not (List.exists is_present db.hintdb_nopat) then + (** FIXME *) { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } else db | Some gr -> @@ -397,8 +437,8 @@ module Hint_db = struct in List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat - let add_one kv db = - let (k,v) = translate_hint kv in + let add_one (k, v) db = + let v = instantiate_hint v in let st',db,rebuild = match v.code with | Unfold_nth egr -> @@ -432,8 +472,8 @@ module Hint_db = struct let remove_one gr db = remove_list [gr] db let iter f db = - f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat); - Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map snd (l@l'))) db.hintdb_map + f None (List.map (fun x -> realize_tac (snd x)) db.hintdb_nopat); + Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map realize_tac (l@l'))) db.hintdb_map let fold f db accu = let accu = f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in @@ -516,7 +556,7 @@ let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable." -let make_exact_entry sigma pri ?(name=PathAny) (c,cty) = +let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = let cty = strip_outer_cast cty in match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" @@ -528,15 +568,17 @@ let make_exact_entry sigma pri ?(name=PathAny) (c,cty) = in (Some hd, { pri = (match pri with None -> 0 | Some p -> p); + poly = poly; pat = Some pat; name = name; - code = Give_exact c }) + code = Give_exact (c, cty, ctx) }) -let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) = +let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = let cty = if hnf then hnf_constr env sigma cty else cty in match kind_of_term cty with | Prod _ -> - let ce = mk_clenv_from dummy_goal (c,cty) in + let sigma' = Evd.merge_context_set univ_flexible dummy_goal.sigma ctx in + let ce = mk_clenv_from { dummy_goal with sigma = sigma' } (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in let pat = snd (Patternops.pattern_of_constr sigma c') in let hd = @@ -546,9 +588,10 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) if Int.equal nmiss 0 then (Some hd, { pri = (match pri with None -> nb_hyp cty | Some p -> p); + poly = poly; pat = Some pat; name = name; - code = Res_pf(c,cty) }) + code = Res_pf(c,cty,ctx) }) else begin if not eapply then failwith "make_apply_entry"; if verbose then @@ -556,9 +599,10 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) str " will only be used by eauto"); (Some hd, { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); + poly = poly; pat = Some pat; name = name; - code = ERes_pf(c,cty) }) + code = ERes_pf(c,cty,ctx) }) end | _ -> failwith "make_apply_entry" @@ -566,12 +610,18 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) c is a constr cty is the type of constr *) -let make_resolves env sigma flags pri ?name c = +let fresh_global_or_constr env sigma poly cr = + match cr with + | IsGlobRef gr -> Universes.fresh_global_instance env gr + | IsConstr (c, ctx) -> (c, ctx) + +let make_resolves env sigma flags pri poly ?name cr = + let c, ctx = fresh_global_or_constr env sigma poly cr in let cty = Retyping.get_type_of env sigma c in let try_apply f = - try Some (f (c, cty)) with Failure _ -> None in + try Some (f (c, cty, ctx)) with Failure _ -> None in let ents = List.map_filter try_apply - [make_exact_entry sigma pri ?name; make_apply_entry env sigma flags pri ?name] + [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name] in if List.is_empty ents then errorlabstrm "Hint" @@ -583,9 +633,9 @@ let make_resolves env sigma flags pri ?name c = (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma (hname,_,htyp) = try - [make_apply_entry env sigma (true, true, false) None + [make_apply_entry env sigma (true, true, false) None false ~name:(PathHints [VarRef hname]) - (mkVar hname, htyp)] + (mkVar hname, htyp, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") @@ -595,6 +645,7 @@ let make_unfold eref = let g = global_of_evaluable_reference eref in (Some g, { pri = 4; + poly = false; pat = None; name = PathHints [g]; code = Unfold_nth eref }) @@ -603,19 +654,21 @@ let make_extern pri pat tacast = let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri = pri; + poly = false; pat = pat; name = PathAny; code = Extern tacast }) -let make_trivial env sigma ?(name=PathAny) r = - let c = constr_of_global_or_constr r in +let make_trivial env sigma poly ?(name=PathAny) r = + let c,ctx = fresh_global_or_constr env sigma poly r in let t = hnf_constr env sigma (type_of env sigma c) in - let hd = head_of_constr_reference (fst (head_constr t)) in + let hd = head_of_constr_reference (head_constr t) in let ce = mk_clenv_from dummy_goal (c,t) in (Some hd, { pri=1; + poly = poly; pat = Some (snd (Patternops.pattern_of_constr sigma (clenv_type ce))); name = name; - code=Res_pf_THEN_trivial_fail(c,t) }) + code=Res_pf_THEN_trivial_fail(c,t,ctx) }) open Vernacexpr @@ -675,11 +728,21 @@ let cache_autohint (_,(local,name,hints)) = let (forward_subst_tactic, extern_subst_tactic) = Hook.make () + (* let subst_mps_or_ref subst cr = *) + (* match cr with *) + (* | IsConstr c -> let c' = subst_mps subst c in *) + (* if c' == c then cr *) + (* else IsConstr c' *) + (* | IsGlobal r -> let r' = subst_global_reference subst r in *) + (* if r' == r then cr *) + (* else IsGlobal r' *) + (* in *) + let subst_autohint (subst,(local,name,hintlist as obj)) = let subst_key gr = let (lab'', elab') = subst_global subst gr in let gr' = - (try head_of_constr_reference (fst (head_constr_bound elab')) + (try head_of_constr_reference (head_constr_bound elab') with Tactics.Bound -> lab'') in if gr' == gr then gr else gr' in @@ -687,21 +750,22 @@ let subst_autohint (subst,(local,name,hintlist as obj)) = let k' = Option.smartmap subst_key k in let pat' = Option.smartmap (subst_pattern subst) data.pat in let code' = match data.code with - | Res_pf (c,t) -> + | Res_pf (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'==t then data.code else Res_pf (c', t') - | ERes_pf (c,t) -> + if c==c' && t'==t then data.code else Res_pf (c', t',ctx) + | ERes_pf (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'==t then data.code else ERes_pf (c',t') - | Give_exact c -> + if c==c' && t'==t then data.code else ERes_pf (c',t',ctx) + | Give_exact (c,t,ctx) -> let c' = subst_mps subst c in - if c==c' then data.code else Give_exact c' - | Res_pf_THEN_trivial_fail (c,t) -> + let t' = subst_mps subst t in + if c==c' && t'== t then data.code else Give_exact (c',t',ctx) + | Res_pf_THEN_trivial_fail (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t') + if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t',ctx) | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in if ref==ref' then data.code else Unfold_nth ref' @@ -765,13 +829,9 @@ let add_resolves env sigma clist local dbnames = Lib.add_anonymous_leaf (inAutoHint (local,dbname, AddHints - (List.flatten (List.map (fun (x, hnf, path, gr) -> - let c = - match gr with - | IsConstr c -> c - | IsGlobal gr -> constr_of_global gr - in - make_resolves env sigma (true,hnf,Flags.is_verbose()) x ~name:path c) clist))))) + (List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> + make_resolves env sigma (true,hnf,Flags.is_verbose()) + pri poly ~name:path gr) clist))))) dbnames let add_unfolds l local dbnames = @@ -808,14 +868,20 @@ let add_trivials env sigma l local dbnames = (fun dbname -> Lib.add_anonymous_leaf ( inAutoHint(local,dbname, - AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l)))) + AddHints (List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l)))) dbnames let (forward_intern_tac, extern_intern_tac) = Hook.make () +type hnf = bool + +let pr_hint_term = function + | IsConstr (c,_) -> pr_constr c + | IsGlobRef gr -> pr_global gr + type hints_entry = - | HintsResolveEntry of (int option * bool * hints_path_atom * global_reference_or_constr) list - | HintsImmediateEntry of (hints_path_atom * global_reference_or_constr) list + | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * hint_term) list + | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool @@ -826,7 +892,7 @@ let h = Id.of_string "H" exception Found of constr * types -let prepare_hint env (sigma,c) = +let prepare_hint check env init (sigma,c) = let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in (* We re-abstract over uninstantiated evars. It is actually a bit stupid to generalize over evars since the first @@ -853,15 +919,16 @@ let prepare_hint env (sigma,c) = vars := Id.Set.add id !vars; subst := (evar,mkVar id)::!subst; mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in - iter c + let c' = iter c in + if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c'; + let diff = Evd.diff sigma init in + IsConstr (c', Evd.get_universe_context_set diff) -let interp_hints = +let interp_hints poly = fun h -> let f c = let evd,c = Constrintern.interp_open_constr Evd.empty (Global.env()) c in - let c = prepare_hint (Global.env()) (evd,c) in - Evarutil.check_evars (Global.env()) Evd.empty evd c; - c in + prepare_hint true (Global.env()) Evd.empty (evd,c) in let fr r = let gr = global_with_alias r in let r' = evaluable_of_global_reference (Global.env()) gr in @@ -871,12 +938,17 @@ let interp_hints = match c with | HintsReference c -> let gr = global_with_alias c in - (PathHints [gr], IsGlobal gr) - | HintsConstr c -> (PathAny, IsConstr (f c)) + (PathHints [gr], poly, IsGlobRef gr) + | HintsConstr c -> + (* if poly then *) + (* errorlabstrm "Hint" (Ppconstr.pr_constr_expr c ++ spc () ++ *) + (* str" is a term and cannot be made a polymorphic hint," ++ *) + (* str" only global references can be polymorphic hints.") *) + (* else *) (PathAny, poly, f c) in - let fres (o, b, c) = - let path, gr = fi c in - (o, b, path, gr) + let fres (pri, b, r) = + let path, poly, gr = fi r in + (pri, poly, b, path, gr) in let fp = Constrintern.intern_constr_pattern (Global.env()) in match h with @@ -888,11 +960,14 @@ let interp_hints = | HintsConstructors lqid -> let constr_hints_of_ind qid = let ind = global_inductive_with_alias qid in + let mib,_ = Global.lookup_inductive ind in Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind"; - List.init (nconstructors ind) (fun i -> let c = (ind,i+1) in - let gr = ConstructRef c in - None, true, PathHints [gr], IsGlobal gr) in - HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) + List.init (nconstructors ind) + (fun i -> let c = (ind,i+1) in + let gr = ConstructRef c in + None, mib.Declarations.mind_polymorphic, true, + PathHints [gr], IsGlobRef gr) + in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> let pat = Option.map fp patcom in let l = match pat with None -> [] | Some (l, _) -> l in @@ -922,7 +997,7 @@ let pr_autotactic = function | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c) | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c) - | Give_exact c -> (str"exact " ++ pr_constr c) + | Give_exact (c,clenv) -> (str"exact " ++ pr_constr c) | Res_pf_THEN_trivial_fail (c,clenv) -> (str"apply " ++ pr_constr c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) @@ -970,11 +1045,11 @@ let pr_hint_term cl = let dbs = current_db () in let valid_dbs = let fn = try - let (hdc,args) = head_constr_bound cl in + let hdc = head_constr_bound cl in let hd = head_of_constr_reference hdc in if occur_existential cl then Hint_db.map_all hd - else Hint_db.map_auto (hd, applist (hdc,args)) + else Hint_db.map_auto (hd, cl) with Bound -> Hint_db.map_none in let fn db = List.map (fun x -> 0, x) (fn db) in @@ -1072,40 +1147,52 @@ let auto_unif_flags = { (* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve_nodelta (c,clenv) gl = - let clenv' = connect_clenv gl clenv in +let unify_resolve_nodelta poly (c,clenv) gl = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gl clenv' in let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in Clenvtac.clenv_refine false clenv'' gl -let unify_resolve flags (c,clenv) gl = - let clenv' = connect_clenv gl clenv in +let unify_resolve poly flags (c,clenv) gl = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gl clenv' in let clenv'' = clenv_unique_resolver ~flags clenv' gl in Clenvtac.clenv_refine false clenv'' gl -let unify_resolve_gen = function - | None -> unify_resolve_nodelta - | Some flags -> unify_resolve flags - +let unify_resolve_gen poly = function + | None -> unify_resolve_nodelta poly + | Some flags -> unify_resolve poly flags + +let exact poly (c,clenv) = + let c' = + if poly then + let evd', subst = Evd.refresh_undefined_universes clenv.evd in + subst_univs_level_constr subst c + else c + in exact_check c' + (* Util *) -let expand_constructor_hints env lems = - List.map_append (fun (sigma,lem) -> +let expand_constructor_hints env sigma lems = + List.map_append (fun (evd,lem) -> match kind_of_term lem with - | Ind ind -> - List.init (nconstructors ind) (fun i -> mkConstruct (ind,i+1)) + | Ind (ind,u) -> + List.init (nconstructors ind) + (fun i -> IsConstr (mkConstructU ((ind,i+1),u), + Univ.ContextSet.empty)) | _ -> - [prepare_hint env (sigma,lem)]) lems + [prepare_hint false env sigma (evd,lem)]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *) let add_hint_lemmas eapply lems hint_db gl = - let lems = expand_constructor_hints (pf_env gl) lems in + let lems = expand_constructor_hints (pf_env gl) (project gl) lems in let hintlist' = - List.map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in + List.map_append (pf_apply make_resolves gl (eapply,true,false) None true) lems in Hint_db.add_list hintlist' hint_db -let make_local_hint_db ?ts eapply lems gl = +let make_local_hint_db ts eapply lems gl = let sign = pf_hyps gl in let ts = match ts with | None -> Hint_db.transparent_state (searchtable_map "core") @@ -1115,6 +1202,15 @@ let make_local_hint_db ?ts eapply lems gl = add_hint_lemmas eapply lems (Hint_db.add_list hintlist (Hint_db.empty ts false)) gl +let make_local_hint_db = + if Flags.profile then + let key = Profile.declare_profile "make_local_hint_db" in + Profile.profile4 key make_local_hint_db + else make_local_hint_db + +let make_local_hint_db ?ts eapply lems gl = + make_local_hint_db ts eapply lems gl + (* Serait-ce possible de compiler d'abord la tactique puis de faire la substitution sans passer par bdize dont l'objectif est de prĂ©parer un terme pour l'affichage ? (HH) *) @@ -1358,15 +1454,15 @@ and my_find_search_delta db_list local_db hdc concl = in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) -and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) = +and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) = let tactic = match t with - | Res_pf (c,cl) -> Proofview.V82.tactic (unify_resolve_gen flags (c,cl)) + | Res_pf (c,cl) -> Proofview.V82.tactic (unify_resolve_gen poly flags (c,cl)) | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf") - | Give_exact c -> Proofview.V82.tactic (exact_check c) + | Give_exact (c, cl) -> Proofview.V82.tactic (exact poly (c, cl)) | Res_pf_THEN_trivial_fail (c,cl) -> Tacticals.New.tclTHEN - (Proofview.V82.tactic (unify_resolve_gen flags (c,cl))) + (Proofview.V82.tactic (unify_resolve_gen poly flags (c,cl))) (* With "(debug) trivial", we shouldn't end here, and with "debug auto" we don't display the details of inner trivial *) (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db) @@ -1382,7 +1478,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) = and trivial_resolve dbg mod_delta db_list local_db cl = try let head = - try let hdconstr,_ = head_constr_bound cl in + try let hdconstr = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None in @@ -1436,7 +1532,7 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l let possible_resolve dbg mod_delta db_list local_db cl = try let head = - try let hdconstr,_ = head_constr_bound cl in + try let hdconstr = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None in @@ -1482,7 +1578,7 @@ let search d n mod_delta db_list local_db = let default_search_depth = ref 5 -let delta_auto ?(debug=Off) mod_delta n lems dbnames = +let delta_auto debug mod_delta n lems dbnames = Proofview.Goal.enter begin fun gl -> let db_list = make_db_list dbnames in let d = mk_auto_dbg debug in @@ -1491,9 +1587,15 @@ let delta_auto ?(debug=Off) mod_delta n lems dbnames = (search d n mod_delta db_list hints) end -let auto ?(debug=Off) n = delta_auto ~debug false n +let delta_auto = + if Flags.profile then + let key = Profile.declare_profile "delta_auto" in + Profile.profile5 key delta_auto + else delta_auto + +let auto ?(debug=Off) n = delta_auto debug false n -let new_auto ?(debug=Off) n = delta_auto ~debug true n +let new_auto ?(debug=Off) n = delta_auto debug true n let default_auto = auto !default_search_depth [] [] diff --git a/tactics/auto.mli b/tactics/auto.mli index 2d27208805..b85f86ea48 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -21,16 +21,17 @@ open Vernacexpr open Mod_subst open Misctypes open Pp +open Decl_kinds (** Auto and related automation tactics *) type 'a auto_tactic = - | Res_pf of constr * 'a (** Hint Apply *) - | ERes_pf of constr * 'a (** Hint EApply *) - | Give_exact of constr - | Res_pf_THEN_trivial_fail of constr * 'a (** Hint Immediate *) - | Unfold_nth of evaluable_global_reference (** Hint Unfold *) - | Extern of Tacexpr.glob_tactic_expr (** Hint Extern *) + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) + | Unfold_nth of evaluable_global_reference (* Hint Unfold *) + | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) type hints_path_atom = | PathHints of global_reference list @@ -38,20 +39,20 @@ type hints_path_atom = type 'a gen_auto_tactic = { pri : int; (** A number between 0 and 4, 4 = lower priority *) + poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (** A pattern for the concl of the Goal *) name : hints_path_atom; (** A potential name to refer to the hint *) code : 'a auto_tactic; (** the tactic to apply when the concl matches pat *) } -type pri_auto_tactic = clausenv gen_auto_tactic - -type stored_data = int * clausenv gen_auto_tactic +type pri_auto_tactic = (constr * clausenv) gen_auto_tactic type search_entry (** The head may not be bound. *) -type hint_entry = global_reference option * types gen_auto_tactic +type hint_entry = global_reference option * + (constr * types * Univ.universe_context_set) gen_auto_tactic type hints_path = | PathAtom of hints_path_atom @@ -94,9 +95,16 @@ type hint_db_name = string type hint_db = Hint_db.t +type hnf = bool + +type hint_term = + | IsGlobRef of global_reference + | IsConstr of constr * Univ.universe_context_set + type hints_entry = - | HintsResolveEntry of (int option * bool * hints_path_atom * global_reference_or_constr) list - | HintsImmediateEntry of (hints_path_atom * global_reference_or_constr) list + | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * + hint_term) list + | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool @@ -118,11 +126,12 @@ val remove_hints : bool -> hint_db_name list -> global_reference list -> unit val current_db_names : unit -> String.Set.t -val interp_hints : hints_expr -> hints_entry +val interp_hints : polymorphic -> hints_expr -> hints_entry val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit -val prepare_hint : env -> open_constr -> constr +val prepare_hint : bool (* Check no remaining evars *) -> env -> evar_map -> + open_constr -> hint_term val pr_searchtable : unit -> std_ppcmds val pr_applicable_hint : unit -> std_ppcmds @@ -134,7 +143,8 @@ val pr_hint_db : Hint_db.t -> std_ppcmds [c] is the term given as an exact proof to solve the goal; [ctyp] is the type of [c]. *) -val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr * constr -> hint_entry +val make_exact_entry : env -> evar_map -> int option -> polymorphic -> ?name:hints_path_atom -> + (constr * types * Univ.universe_context_set) -> hint_entry (** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)]. [eapply] is true if this hint will be used only with EApply; @@ -144,8 +154,8 @@ val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr [cty] is the type of [c]. *) val make_apply_entry : - env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> - constr * constr -> hint_entry + env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + (constr * types * Univ.universe_context_set) -> hint_entry (** A constr which is Hint'ed will be: - (1) used as an Exact, if it does not start with a product @@ -155,8 +165,8 @@ val make_apply_entry : has missing arguments. *) val make_resolves : - env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> - constr -> hint_entry list + env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + hint_term -> hint_entry list (** [make_resolve_hyp hname htyp]. used to add an hypothesis to the local hint database; @@ -194,9 +204,9 @@ val default_search_depth : int ref val auto_unif_flags : Unification.unify_flags (** Try unification with the precompiled clause, then use registered Apply *) -val unify_resolve_nodelta : (constr * clausenv) -> tactic +val unify_resolve_nodelta : polymorphic -> (constr * clausenv) -> tactic -val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic +val unify_resolve : polymorphic -> Unification.unify_flags -> (constr * clausenv) -> tactic (** [ConclPattern concl pat tacast]: if the term concl matches the pattern pat, (in sense of @@ -255,7 +265,7 @@ val full_trivial : ?debug:Tacexpr.debug -> val h_trivial : ?debug:Tacexpr.debug -> open_constr list -> hint_db_name list option -> unit Proofview.tactic -val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds +val pr_autotactic : (constr * 'a) auto_tactic -> Pp.std_ppcmds (** Hook for changing the initialization of auto *) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index ba36761459..0809c0500b 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -23,6 +23,7 @@ open Locus type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; + rew_ctx: Univ.universe_context_set; rew_l2r: bool; rew_tac: glob_tactic_expr option } @@ -85,18 +86,26 @@ let print_rewrite_hintdb bas = Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) -type raw_rew_rule = Loc.t * constr * bool * raw_tactic_expr option +type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in + let try_rewrite dir ctx c tc = Proofview.Goal.enter (fun gl -> + let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c in + let sigma = Proofview.Goal.sigma gl in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in + Tacticals.New.tclTHEN (Proofview.V82.tclEVARS sigma) + (general_rewrite_maybe_in dir c' tc) + ) in let lrul = List.map (fun h -> let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in - (h.rew_lemma,h.rew_l2r,tac)) lrul in - Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) -> + (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> Tacticals.New.tclTHEN tac (Tacticals.New.tclREPEAT_MAIN - (Tacticals.New.tclTHENFIRST (general_rewrite_maybe_in dir csr tc) tac_main))) + (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) (Proofview.tclUNIT()) lrul)) (* The AutoRewrite tactic *) @@ -284,11 +293,11 @@ let add_rew_rules base lrul = let counter = ref 0 in let lrul = List.fold_left - (fun dn (loc,c,b,t) -> + (fun dn (loc,(c,ctx),b,t) -> let info = find_applied_relation false loc (Global.env ()) Evd.empty c b in let pat = if b then info.hyp_left else info.hyp_right in let rul = { rew_lemma = c; rew_type = info.hyp_ty; - rew_pat = pat; rew_l2r = b; + rew_pat = pat; rew_ctx = ctx; rew_l2r = b; rew_tac = Option.map Tacintern.glob_tactic t} in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 198fa36f59..0462911358 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -11,7 +11,7 @@ open Tacexpr open Equality (** Rewriting rules before tactic interpretation *) -type raw_rew_rule = Loc.t * Term.constr * bool * Tacexpr.raw_tactic_expr option +type raw_rew_rule = Loc.t * Term.constr Univ.in_universe_context_set * bool * Tacexpr.raw_tactic_expr option (** To add rewriting rules to a base *) val add_rew_rules : string -> raw_rew_rule list -> unit @@ -27,6 +27,7 @@ val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; + rew_ctx: Univ.universe_context_set; rew_l2r: bool; rew_tac: glob_tactic_expr option } diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 9492ae1a0a..df8e98604b 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -48,8 +48,8 @@ let decomp = let constr_val_discr t = let c, l = decomp t in match kind_of_term c with - | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l) - | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l) + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id -> Label(GRLabel (VarRef id),l) | Const _ -> Everything | _ -> Nothing @@ -67,9 +67,9 @@ let constr_pat_discr t = let constr_val_discr_st (idpred,cpred) t = let c, l = decomp t in match kind_of_term c with - | Const c -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) - | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l) - | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l) + | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l) @@ -141,6 +141,77 @@ struct let create = Dn.create +(* FIXME: MS: remove *) +(* let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Proj (p,c) -> decrec (c :: acc) (mkConst p) + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] + + let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Const _ -> Dn.Everything + | Proj (p, c) -> Dn.Everything + | _ -> Dn.Nothing + + let constr_val_discr_st (idpred,cpred) t = + let c, l = decomp t in + match kind_of_term c with + | Const (c,_) -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l) + | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Proj (p,c) -> + if Cpred.mem p cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef p), c::l) + | Var id when not (Id.Pred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c]) + | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l) + | Sort _ -> Dn.Label(Term_dn.SortLabel, []) + | Evar _ -> Dn.Everything + | _ -> Dn.Nothing + + let bounded_constr_pat_discr_st st (t,depth) = + if Int.equal depth 0 then + None + else + match Term_dn.constr_pat_discr_st st t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + + let bounded_constr_val_discr_st st (t,depth) = + if Int.equal depth 0 then + Dn.Nothing + else + match constr_val_discr_st st t with + | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) + | Dn.Nothing -> Dn.Nothing + | Dn.Everything -> Dn.Everything + + let bounded_constr_pat_discr (t,depth) = + if Int.equal depth 0 then + None + else + match Term_dn.constr_pat_discr t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + + let bounded_constr_val_discr (t,depth) = + if Int.equal depth 0 then + Dn.Nothing + else + match constr_val_discr t with + | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) + | Dn.Nothing -> Dn.Nothing + | Dn.Everything -> Dn.Everything + +*) + let add = function | None -> (fun dn (c,v) -> diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 6d7c797af0..02e671a5c1 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -50,7 +50,7 @@ let evars_to_goals p evm = open Auto -let e_give_exact flags c gl = +let e_give_exact flags (c,cl) gl = let t1 = (pf_type_of gl c) in tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl @@ -91,15 +91,17 @@ let progress_evars t = in t <*> check end -let unify_e_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in +let unify_e_resolve poly flags (c,clenv) gls = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gls clenv' in let clenv' = clenv_unique_resolver ~flags clenv' gls in Clenvtac.clenv_refine true ~with_classes:false clenv' gls -let unify_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in +let unify_resolve poly flags (c,clenv) gls = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gls clenv' in let clenv' = clenv_unique_resolver ~flags clenv' gls in - Clenvtac.clenv_refine false ~with_classes:false clenv' gls + Clenvtac.clenv_refine false(*uhoh, was true*) ~with_classes:false clenv' gls let clenv_of_prods nprods (c, clenv) gls = if Int.equal nprods 0 then Some clenv @@ -107,6 +109,7 @@ let clenv_of_prods nprods (c, clenv) gls = let ty = pf_type_of gls c in let diff = nb_prod ty - nprods in if Pervasives.(>=) diff 0 then + (* Was Some clenv... *) Some (mk_clenv_from_n gls (Some diff) (c,ty)) else None @@ -152,14 +155,14 @@ and e_my_find_search db_list local_db hdc complete concl = (local_db::db_list) in let tac_of_hint = - fun (flags, {pri = b; pat = p; code = t; name = name}) -> + fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> let tac = match t with - | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve flags) - | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve flags) - | Give_exact (c) -> e_give_exact flags c + | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve poly flags) + | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve poly flags) + | Give_exact c -> e_give_exact flags c | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags)) + tclTHEN (with_prods nprods (term,cl) (unify_e_resolve poly flags)) (if complete then tclIDTAC else e_trivial_fail_db db_list local_db) | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c]) | Extern tacast -> @@ -178,13 +181,13 @@ and e_my_find_search db_list local_db hdc complete concl = and e_trivial_resolve db_list local_db gl = try e_my_find_search db_list local_db - (fst (head_constr_bound gl)) true gl + (head_constr_bound gl) true gl with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try e_my_find_search db_list local_db - (fst (head_constr_bound gl)) false gl + (head_constr_bound gl) false gl with Bound | Not_found -> [] let catchable = function @@ -223,8 +226,8 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = let rec iscl env ty = let ctx, ar = decompose_prod_assum ty in match kind_of_term (fst (decompose_app ar)) with - | Const c -> is_class (ConstRef c) - | Ind i -> is_class (IndRef i) + | Const (c,_) -> is_class (ConstRef c) + | Ind (i,_) -> is_class (IndRef i) | _ -> let env' = Environ.push_rel_context ctx env in let ty' = whd_betadeltaiota env' ar in @@ -241,13 +244,16 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = let hints = build_subclasses ~check:false env sigma (VarRef id) None in (List.map_append (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) - (true,false,Flags.is_verbose()) pri c) + (true,false,Flags.is_verbose()) pri false + (IsConstr (c,Univ.ContextSet.empty))) hints) else [] in (hints @ List.map_filter - (fun f -> try Some (f (c, cty)) with Failure _ | UserError _ -> None) - [make_exact_entry ~name sigma pri; make_apply_entry ~name env sigma flags pri]) + (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) + with Failure _ | UserError _ -> None) + [make_exact_entry ~name env sigma pri false; + make_apply_entry ~name env sigma flags pri false]) else [] let pf_filtered_hyps gls = @@ -266,21 +272,19 @@ let make_hints g st only_classes sign = (PathEmpty, []) sign in Hint_db.add_list hintlist (Hint_db.empty st true) -let autogoal_hints_cache - : (bool * Environ.named_context_val * hint_db) option ref - = Summary.ref None ~name:"autogoal-hints-cache" -let freeze () = !autogoal_hints_cache -let unfreeze v = autogoal_hints_cache := v - let make_autogoal_hints = - fun only_classes ?(st=full_transparent_state) g -> - let sign = pf_filtered_hyps g in - match freeze () with - | Some (onlyc, sign', hints) - when (onlyc : bool) == only_classes && - Environ.eq_named_context_val sign sign' -> hints - | _ -> let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in - unfreeze (Some (only_classes, sign, hints)); hints + let cache = ref (true, Environ.empty_named_context_val, + Hint_db.empty full_transparent_state true) + in + fun only_classes ?(st=full_transparent_state) g -> + let sign = pf_filtered_hyps g in + let (onlyc, sign', cached_hints) = !cache in + if onlyc == only_classes && + (sign == sign' || Environ.eq_named_context_val sign sign') then + cached_hints + else + let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in + cache := (only_classes, sign, hints); hints let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = { skft = fun sk fk {it = gl,hints; sigma=s;} -> @@ -467,7 +471,8 @@ let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm hints t let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st hints goals evm') in match get_result res with | None -> raise Not_found - | Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true evm' evm, fk) + | Some (evm', fk) -> + Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) let eauto_tac hints = then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) @@ -743,4 +748,4 @@ let autoapply c i gl = let flags = flags_of_state (Auto.Hint_db.transparent_state (Auto.searchtable_map i)) in let cty = pf_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - unify_e_resolve flags (c,ce) gl + unify_e_resolve false flags (c,ce) gl diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index f245247a91..faeb9fc25e 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -34,6 +34,7 @@ let absurd c gls = exact_no_check (mkApp(mkVar idna,[|mkVar ida|])) gl))); tclIDTAC])); tclIDTAC])) { gls with Evd.sigma; } + let absurd c = Proofview.V82.tactic (absurd c) (* Contradiction *) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 0ab426cd2e..328d45991b 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -32,7 +32,7 @@ let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_tr let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in if occur_existential t1 || occur_existential t2 then - tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl + tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl else exact_check c gl let assumption id = e_give_exact (mkVar id) @@ -86,8 +86,12 @@ let rec prolog l n gl = let prol = (prolog l (n-1)) in (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl +let out_term = function + | IsConstr (c, _) -> c + | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) + let prolog_tac l n gl = - let l = List.map (prepare_hint (pf_env gl)) l in + let l = List.map (fun x -> out_term (pf_apply (prepare_hint false) gl x)) l in let n = match n with | ArgArg n -> n @@ -110,11 +114,19 @@ open Unification let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) -let unify_e_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in +let unify_e_resolve poly flags (c,clenv) gls = + let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst in + let clenv' = connect_clenv gls clenv' in let _ = clenv_unique_resolver ~flags clenv' gls in - Tactics.Simple.eapply c gls - + Tactics.Simple.eapply (Vars.subst_univs_level_constr subst c) gls + +let e_exact poly flags (c,clenv) = + let clenv', subst = + if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst + in e_give_exact ~flags (Vars.subst_univs_level_constr subst c) + let rec e_trivial_fail_db db_list local_db goal = let tacl = registered_e_assumption :: @@ -141,15 +153,15 @@ and e_my_find_search db_list local_db hdc concl = List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) in let tac_of_hint = - fun (st, {pri=b; pat = p; code=t}) -> + fun (st, {pri = b; pat = p; code = t; poly = poly}) -> (b, let tac = match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve st (term,cl) - | Give_exact (c) -> e_give_exact c + | Res_pf (term,cl) -> unify_resolve poly st (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) + | Give_exact (c,cl) -> e_exact poly st (c,cl) | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve st (term,cl)) + tclTHEN (unify_e_resolve poly st (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl | Extern tacast -> Proofview.V82.of_tactic (conclPattern concl p tacast) @@ -162,13 +174,13 @@ and e_trivial_resolve db_list local_db gl = try priority (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) + (head_constr_bound gl) gl) with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try List.map snd (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) + (head_constr_bound gl) gl) with Bound | Not_found -> [] let find_first_goal gls = @@ -363,6 +375,9 @@ let e_search_auto debug (in_depth,p) lems db_list gl = pr_info_nop d; error "eauto: search failed" +(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) +(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) + let eauto_with_bases ?(debug=Off) np lems db_list = tclTRY (e_search_auto debug np lems db_list) @@ -494,8 +509,8 @@ let unfold_head env (ids, csts) c = (match Environ.named_body id env with | Some b -> true, b | None -> false, c) - | Const cst when Cset.mem cst csts -> - true, Environ.constant_value env cst + | Const (cst,u as c) when Cset.mem cst csts -> + true, Environ.constant_value_in env c | App (f, args) -> (match aux f with | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) @@ -558,7 +573,7 @@ TACTIC EXTEND autounfoldify | [ "autounfoldify" constr(x) ] -> [ Proofview.V82.tactic ( let db = match kind_of_term x with - | Const c -> Label.to_string (con_label c) + | Const (c,_) -> Label.to_string (con_label c) | _ -> assert false in autounfold ["core";db] onConcl )] diff --git a/tactics/elim.ml b/tactics/elim.ml index 0720273bb8..2a7b3bff1c 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -104,12 +104,12 @@ let head_in indl t gl = if !up_to_delta then find_mrectype env sigma t else extract_mrectype t - in List.exists (fun i -> eq_ind i ity) indl + in List.exists (fun i -> eq_ind (fst i) (fst ity)) indl with Not_found -> false let decompose_these c l = Proofview.Goal.raw_enter begin fun gl -> - let indl = (*List.map inductive_of*) l in + let indl = List.map (fun x -> x, Univ.Instance.empty) l in general_decompose (fun (_,t) -> head_in indl t gl) c end diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 9c020930c8..617475bb73 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -23,13 +23,16 @@ open Ind_tables (* Induction/recursion schemes *) let optimize_non_type_induction_scheme kind dep sort ind = + let env = Global.env () in + let sigma = Evd.from_env env in if check_scheme kind ind then (* in case the inductive has a type elimination, generates only one induction scheme, the other ones share the same code with the apropriate type *) let cte, eff = find_scheme kind ind in - let c = mkConst cte in - let t = type_of_constant (Global.env()) cte in + let sigma, cte = Evd.fresh_constant_instance env sigma cte in + let c = mkConstU cte in + let t = type_of_constant_in (Global.env()) cte in let (mib,mip) = Global.lookup_inductive ind in let npars = (* if a constructor of [ind] contains a recursive call, the scheme @@ -39,13 +42,29 @@ let optimize_non_type_induction_scheme kind dep sort ind = mib.mind_nparams_rec else mib.mind_nparams in - snd (weaken_sort_scheme (new_sort_in_family sort) npars c t), eff + let sigma, sort = Evd.fresh_sort_in_family env sigma sort in + let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in + let sigma, nf = Evarutil.nf_evars_and_universes sigma in + (nf c', Evd.evar_universe_context sigma), eff else - build_induction_scheme (Global.env()) Evd.empty ind dep sort, Declareops.no_seff + let mib,mip = Inductive.lookup_mind_specif env ind in + let ctx = if mib.mind_polymorphic then mib.mind_universes else Univ.UContext.empty in + let u = Univ.UContext.instance ctx in + let ctxset = Univ.ContextSet.of_context ctx in + let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ctxset env) (ind,u) dep sort in + (c, Evd.evar_universe_context sigma), Declareops.no_seff let build_induction_scheme_in_type dep sort ind = - build_induction_scheme (Global.env()) Evd.empty ind dep sort - + let env = Global.env () in + let ctx = + let mib,mip = Inductive.lookup_mind_specif env ind in + Inductive.inductive_context mib + in + let u = Univ.UContext.instance ctx in + let ctxset = Univ.ContextSet.of_context ctx in + let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ctxset env) (ind,u) dep sort in + c, Evd.evar_universe_context sigma + let rect_scheme_kind_from_type = declare_individual_scheme_object "_rect_nodep" (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) @@ -81,7 +100,11 @@ let rec_dep_scheme_kind_from_type = (* Case analysis *) let build_case_analysis_scheme_in_type dep sort ind = - build_case_analysis_scheme (Global.env()) Evd.empty ind dep sort + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, indu = Evd.fresh_inductive_instance env sigma ind in + let sigma, c = build_case_analysis_scheme env sigma indu dep sort in + c, Evd.evar_universe_context sigma let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 23c4c0b2d9..7909b669bf 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -80,8 +80,13 @@ let solveNoteqBranch side = (* Constructs the type {c1=c2}+{~c1=c2} *) +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + let mkDecideEqGoal eqonleft op rectype c1 c2 = - let equality = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in + let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in let disequality = mkApp(build_coq_not (), [|equality|]) in if eqonleft then mkApp(op, [|equality; disequality |]) else mkApp(op, [|disequality; equality |]) @@ -173,7 +178,7 @@ let decideGralEquality = match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> let headtyp = hd_app (pf_compute gl typ) in begin match kind_of_term headtyp with - | Ind mi -> Proofview.tclUNIT mi + | Ind (mi,_) -> Proofview.tclUNIT mi | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") end >>= fun rectype -> (tclTHEN diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 7aac37d1b2..08c887b77e 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -63,11 +63,13 @@ let hid = Id.of_string "H" let xid = Id.of_string "X" let default_id_of_sort = function InProp | InSet -> hid | InType -> xid let fresh env id = next_global_ident_away id [] +let with_context_set ctx (b, ctx') = + (b, Univ.ContextSet.union ctx ctx') let build_dependent_inductive ind (mib,mip) = let realargs,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in applist - (mkInd ind, + (mkIndU ind, extended_rel_list mip.mind_nrealargs_ctxt mib.mind_params_ctxt @ extended_rel_list 0 realargs) @@ -76,12 +78,13 @@ let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s let my_it_mkLambda_or_LetIn_name s c = it_mkLambda_or_LetIn_name (Global.env()) c s -let get_coq_eq () = +let get_coq_eq ctx = try let eq = Globnames.destIndRef Coqlib.glob_eq in - let _ = Global.lookup_inductive eq in (* Do not force the lazy if they are not defined *) - mkInd eq, Coqlib.build_coq_eq_refl () + let eq, ctx = with_context_set ctx + (Universes.fresh_inductive_instance (Global.env ()) eq) in + mkIndU eq, mkConstructUi (eq,1), ctx with Not_found -> error "eq not found." @@ -94,12 +97,14 @@ let get_coq_eq () = (* in which case, a symmetry lemma is definable *) (**********************************************************************) -let get_sym_eq_data env ind = +let get_sym_eq_data env (ind,u) = let (mib,mip as specif) = lookup_mind_specif env ind in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; - let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let subst = Inductive.make_inductive_subst mib u in + let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in + let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported."; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in @@ -110,12 +115,13 @@ let get_sym_eq_data env ind = if mip.mind_nrealargs > mib.mind_nparams then error "Constructors arguments must repeat the parameters."; let _,params2 = List.chop (mib.mind_nparams-mip.mind_nrealargs) params in + let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in let paramsctxt1,_ = - List.chop (mib.mind_nparams-mip.mind_nrealargs) mib.mind_params_ctxt in + List.chop (mib.mind_nparams-mip.mind_nrealargs) paramsctxt in if not (List.equal eq_constr params2 constrargs) then error "Constructors arguments must repeat the parameters."; (* nrealargs_ctxt and nrealargs are the same here *) - (specif,mip.mind_nrealargs,realsign,mib.mind_params_ctxt,paramsctxt1) + (specif,mip.mind_nrealargs,realsign,paramsctxt,paramsctxt1) (**********************************************************************) (* Check if an inductive type [ind] has the form *) @@ -127,12 +133,14 @@ let get_sym_eq_data env ind = (* such that symmetry is a priori definable *) (**********************************************************************) -let get_non_sym_eq_data env ind = +let get_non_sym_eq_data env (ind,u) = let (mib,mip as specif) = lookup_mind_specif env ind in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; - let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let subst = Inductive.make_inductive_subst mib u in + let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in + let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported"; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in @@ -140,7 +148,9 @@ let get_non_sym_eq_data env ind = if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; let _,constrargs = List.chop mib.mind_nparams constrargs in - (specif,constrargs,realsign,mip.mind_nrealargs) + let constrargs = List.map (Vars.subst_univs_constr subst) constrargs in + let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in + (specif,constrargs,realsign,paramsctxt,mip.mind_nrealargs) (**********************************************************************) (* Build the symmetry lemma associated to an inductive type *) @@ -157,30 +167,35 @@ let get_non_sym_eq_data env ind = (**********************************************************************) let build_sym_scheme env ind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in + get_sym_eq_data env indu in let cstr n = - mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (mkInd ind,Array.concat + (mkApp (mkIndU indu,Array.concat [extended_rel_vect (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs])), mkRel 1 (* varH *), [|cstr (nrealargs+1)|])))) + in c, Evd.evar_universe_context_of ctx let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" - (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind, Declareops.no_seff) + (fun ind -> + let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in + (c, ctx), Declareops.no_seff) (**********************************************************************) (* Build the involutivity of symmetry for an inductive type *) @@ -198,51 +213,59 @@ let sym_scheme_kind = (* *) (**********************************************************************) +let const_of_scheme kind env ind ctx = + let sym_scheme, eff = (find_scheme kind ind) in + let sym, ctx = with_context_set ctx + (Universes.fresh_constant_instance (Global.env()) sym_scheme) in + mkConstU sym, ctx, eff + let build_sym_involutive_scheme env ind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in - let c, eff = find_scheme sym_scheme_kind ind in - let sym = mkConst c in - let (eq,eqrefl) = get_coq_eq () in - let cstr n = mkApp (mkConstruct(ind,1),extended_rel_vect n paramsctxt) in + get_sym_eq_data env indu in + let eq,eqrefl,ctx = get_coq_eq ctx in + let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let cstr n = mkApp (mkConstructUi (indu,1),extended_rel_vect n paramsctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_C = mkApp - (mkInd ind, Array.append + (mkIndU indu, Array.append (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt) (rel_vect (nrealargs+1) nrealargs)) in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in - (my_it_mkLambda_or_LetIn paramsctxt - (my_it_mkLambda_or_LetIn_name realsign_ind - (mkCase (ci, - my_it_mkLambda_or_LetIn_name - (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (eq,[| - mkApp - (mkInd ind, Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect (2*nrealargs+2) nrealargs; - rel_vect 1 nrealargs]); - mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect 1 nrealargs; - rel_vect (2*nrealargs+2) nrealargs; - [|mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect (2*nrealargs+2) nrealargs; - rel_vect 1 nrealargs; - [|mkRel 1|]])|]]); - mkRel 1|])), - mkRel 1 (* varH *), - [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))), - eff + let c = + (my_it_mkLambda_or_LetIn paramsctxt + (my_it_mkLambda_or_LetIn_name realsign_ind + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkApp (eq,[| + mkApp + (mkIndU indu, Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs]); + mkApp (sym,Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect 1 nrealargs; + rel_vect (2*nrealargs+2) nrealargs; + [|mkApp (sym,Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs; + [|mkRel 1|]])|]]); + mkRel 1|])), + mkRel 1 (* varH *), + [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) + in (c, Evd.evar_universe_context_of ctx), eff let sym_involutive_scheme_kind = declare_individual_scheme_object "_sym_involutive" - (fun ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) + (fun ind -> + build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) (**********************************************************************) (* Build the left-to-right rewriting lemma for conclusion associated *) @@ -305,28 +328,27 @@ let sym_involutive_scheme_kind = (**********************************************************************) let build_l2r_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in - let c, eff = find_scheme sym_scheme_kind ind in - let sym = mkConst c in - let c, eff' = find_scheme sym_involutive_scheme_kind ind in - let sym_involutive = mkConst c in - let (eq,eqrefl) = get_coq_eq () in + get_sym_eq_data env indu in + let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let sym_involutive, ctx, eff' = const_of_scheme sym_involutive_scheme_kind env ind ctx in + let eq,eqrefl,ctx = get_coq_eq ctx in let cstr n p = - mkApp (mkConstruct(ind,1), + mkApp (mkConstructUi(indu,1), Array.concat [extended_rel_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs) paramsctxt1; rel_vect 0 nrealargs; rel_vect nrealargs nrealargs]) in let applied_ind_G = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs+3) paramsctxt1; rel_vect (nrealargs+3) nrealargs; rel_vect 0 nrealargs]) in @@ -345,9 +367,11 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect (nrealargs+4) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]]) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in - let cieq = make_case_info (Global.env()) (destInd eq) RegularStyle in + let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append (extended_rel_vect 1 realsign) (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in @@ -372,6 +396,7 @@ let build_l2r_rew_scheme dep env ind kind = my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, applied_sym_C 3, [|mkVar varHC|]) in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varP @@ -388,8 +413,8 @@ let build_l2r_rew_scheme dep env ind kind = Array.append (extended_rel_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]), [|main_body|]) else - main_body)))))), - Declareops.union_side_effects eff' eff + main_body)))))) + in (c, Evd.evar_universe_context_of ctx), Declareops.union_side_effects eff' eff (**********************************************************************) (* Build the left-to-right rewriting lemma for hypotheses associated *) @@ -418,23 +443,24 @@ let build_l2r_rew_scheme dep env ind kind = (**********************************************************************) let build_l2r_forward_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in + get_sym_eq_data env indu in let cstr n p = - mkApp (mkConstruct(ind,1), + mkApp (mkConstructUi(indu,1), Array.concat [extended_rel_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (4*nrealargs+2) paramsctxt1; rel_vect 0 nrealargs; rel_vect (nrealargs+1) nrealargs]) in let applied_ind_P' = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs+1) paramsctxt1; rel_vect 0 nrealargs; rel_vect (2*nrealargs+1) nrealargs]) in @@ -443,7 +469,9 @@ let build_l2r_forward_rew_scheme dep env ind kind = name_context env ((Name varH,None,applied_ind)::realsign) in let realsign_ind_P n aP = name_context env ((Name varH,None,aP)::realsign_P n) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append @@ -457,6 +485,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = let applied_PG = mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs) (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varH applied_ind @@ -473,6 +502,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) (mkNamedLambda varHC applied_PC' (mkVar varHC))|]))))) + in c, Evd.evar_universe_context_of ctx (**********************************************************************) (* Build the right-to-left rewriting lemma for hypotheses associated *) @@ -504,19 +534,22 @@ let build_l2r_forward_rew_scheme dep env ind kind = (* statement but no need for symmetry of the equality. *) (**********************************************************************) -let build_r2l_forward_rew_scheme dep env ind kind = - let ((mib,mip as specif),constrargs,realsign,nrealargs) = - get_non_sym_eq_data env ind in +let build_r2l_forward_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in + let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) = + get_non_sym_eq_data env indu in let cstr n = - mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in let constrargs_cstr = constrargs@[cstr 0] in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in let applied_PC = applist (mkVar varP,if dep then constrargs_cstr else constrargs) in @@ -524,7 +557,8 @@ let build_r2l_forward_rew_scheme dep env ind kind = mkApp (mkVar varP, if dep then extended_rel_vect 0 realsign_ind else extended_rel_vect 1 realsign) in - (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + let c = + (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkNamedLambda varP (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1) @@ -541,6 +575,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = lift (nrealargs+3) applied_PC, mkRel 1)|]), [|mkVar varHC|])))))) + in c, Evd.evar_universe_context_of ctx (**********************************************************************) (* This function "repairs" the non-dependent r2l forward rewriting *) @@ -558,11 +593,12 @@ let build_r2l_forward_rew_scheme dep env ind kind = (* *) (**********************************************************************) -let fix_r2l_forward_rew_scheme c = +let fix_r2l_forward_rew_scheme (c, ctx') = let t = Retyping.get_type_of (Global.env()) Evd.empty c in let ctx,_ = decompose_prod_assum t in match ctx with | hp :: p :: ind :: indargs -> + let c' = my_it_mkLambda_or_LetIn indargs (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 1) p) (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 2) hp) @@ -570,6 +606,7 @@ let fix_r2l_forward_rew_scheme c = (Reductionops.whd_beta Evd.empty (applist (c, extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) + in c', ctx' | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme") (**********************************************************************) @@ -592,9 +629,16 @@ let fix_r2l_forward_rew_scheme c = (* (H:I q1..qm a1..an), *) (* P b1..bn C -> P a1..an H *) (**********************************************************************) - + let build_r2l_rew_scheme dep env ind k = - build_case_analysis_scheme env Evd.empty ind dep k + let sigma, indu = Evd.fresh_inductive_instance env (Evd.from_env env) ind in + let sigma', c = build_case_analysis_scheme env sigma indu dep k in + c, Evd.evar_universe_context sigma' + +let build_l2r_rew_scheme = build_l2r_rew_scheme +let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme +let build_r2l_rew_scheme = build_r2l_rew_scheme +let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme (**********************************************************************) (* Register the rewriting schemes *) @@ -681,17 +725,22 @@ let rew_r2l_scheme_kind = (* TODO: extend it to types with more than one index *) -let build_congr env (eq,refl) ind = +let build_congr env (eq,refl,ctx) ind = + let (ind,u as indu), ctx = with_context_set ctx + (Universes.fresh_inductive_instance env ind) in let (mib,mip) = lookup_mind_specif env ind in + let subst = Inductive.make_inductive_subst mib u in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; if not (Int.equal mip.mind_nrealargs 1) then error "Expect an inductive type with one predicate parameter."; let i = 1 in - let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in + let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in + let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported."; - let env_with_arity = push_rel_context mip.mind_arity_ctxt env in + let env_with_arity = push_rel_context arityctxt env in let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in @@ -702,14 +751,16 @@ let build_congr env (eq,refl) ind = let varH = fresh env (Id.of_string "H") in let varf = fresh env (Id.of_string "f") in let ci = make_case_info (Global.env()) ind RegularStyle in - my_it_mkLambda_or_LetIn mib.mind_params_ctxt - (mkNamedLambda varB (new_Type ()) + let uni, ctx = Universes.extend_context (Universes.new_global_univ ()) ctx in + let c = + my_it_mkLambda_or_LetIn paramsctxt + (mkNamedLambda varB (mkSort (Type uni)) (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB)) (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign) (mkNamedLambda varH (applist - (mkInd ind, - extended_rel_list (mip.mind_nrealargs+2) mib.mind_params_ctxt @ + (mkIndU indu, + extended_rel_list (mip.mind_nrealargs+2) paramsctxt @ extended_rel_list 0 realsign)) (mkCase (ci, my_it_mkLambda_or_LetIn_name @@ -717,9 +768,9 @@ let build_congr env (eq,refl) ind = (mkLambda (Anonymous, applist - (mkInd ind, + (mkIndU indu, extended_rel_list (2*mip.mind_nrealargs_ctxt+3) - mib.mind_params_ctxt + paramsctxt @ extended_rel_list 0 realsign), mkApp (eq, [|mkVar varB; @@ -729,8 +780,9 @@ let build_congr env (eq,refl) ind = [|mkApp (refl, [|mkVar varB; mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|])))))) + in c, Evd.evar_universe_context_of ctx let congr_scheme_kind = declare_individual_scheme_object "_congr" (fun ind -> (* May fail if equality is not defined *) - build_congr (Global.env()) (get_coq_eq ()) ind, Declareops.no_seff) + build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index 72412d12dc..f18991d72f 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -22,24 +22,26 @@ val rew_l2r_forward_dep_scheme_kind : individual scheme_kind val rew_r2l_dep_scheme_kind : individual scheme_kind val rew_r2l_scheme_kind : individual scheme_kind -val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr -val build_l2r_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr * Declareops.side_effects +val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> + constr Evd.in_evar_universe_context +val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> + constr Evd.in_evar_universe_context * Declareops.side_effects val build_r2l_forward_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr + bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context val build_l2r_forward_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr + bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context (** Builds a symmetry scheme for a symmetrical equality type *) -val build_sym_scheme : env -> inductive -> constr +val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context val sym_scheme_kind : individual scheme_kind -val build_sym_involutive_scheme : - env -> inductive -> constr * Declareops.side_effects +val build_sym_involutive_scheme : env -> inductive -> + constr Evd.in_evar_universe_context * Declareops.side_effects val sym_involutive_scheme_kind : individual scheme_kind (** Builds a congruence scheme for an equality type *) val congr_scheme_kind : individual scheme_kind -val build_congr : env -> constr * constr -> inductive -> constr +val build_congr : env -> constr * constr * Univ.universe_context_set -> inductive -> + constr Evd.in_evar_universe_context diff --git a/tactics/equality.ml b/tactics/equality.ml index b062da23e0..57931f6006 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1,4 +1,4 @@ -(************************************************************************) +1(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) @@ -280,33 +280,32 @@ let jmeq_same_dom gl = function let find_elim hdcncl lft2rgt dep cls ot gl = let inccl = Option.is_empty cls in - let hdcncl_is u = eq_constr hdcncl (constr_of_reference u) in - if (hdcncl_is (Coqlib.glob_eq) || - hdcncl_is (Coqlib.glob_jmeq) && jmeq_same_dom gl ot) - && not dep - || Flags.version_less_or_equal Flags.V8_2 + if (is_global Coqlib.glob_eq hdcncl || + (is_global Coqlib.glob_jmeq hdcncl && + jmeq_same_dom gl ot)) && not dep + || Flags.version_less_or_equal Flags.V8_2 then match kind_of_term hdcncl with - | Ind ind_sp -> + | Ind (ind_sp,u) -> let pr1 = lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) in begin match lft2rgt, cls with | Some true, None | Some false, Some _ -> - let c1 = destConst pr1 in + let c1 = destConstRef pr1 in let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in begin try let _ = Global.lookup_constant c1' in - mkConst c1', Declareops.no_seff + c1', Declareops.no_seff with Not_found -> let rwr_thm = Label.to_string l' in error ("Cannot find rewrite principle "^rwr_thm^".") end - | _ -> pr1, Declareops.no_seff + | _ -> destConstRef pr1, Declareops.no_seff end | _ -> (* cannot occur since we checked that we are in presence of @@ -326,9 +325,9 @@ let find_elim hdcncl lft2rgt dep cls ot gl = | true, _, false -> rew_r2l_forward_dep_scheme_kind in match kind_of_term hdcncl with - | Ind ind -> + | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in - mkConst c , eff + c , eff | _ -> assert false let type_of_clause cls gl = match cls with @@ -342,10 +341,13 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun c type_of_cls in let (elim,effs) = find_elim hdcncl lft2rgt dep cls (Some t) gl in + let tac elim = + general_elim_clause with_evars frzevars tac cls c t l + (match lft2rgt with None -> false | Some b -> b) + {elimindex = None; elimbody = (elim,NoBindings)} + in Proofview.tclEFFECTS effs <*> - general_elim_clause with_evars frzevars tac cls c t l - (match lft2rgt with None -> false | Some b -> b) - {elimindex = None; elimbody = (elim,NoBindings)} + pf_constr_of_global (ConstRef elim) tac end let adjust_rewriting_direction args lft2rgt = @@ -534,26 +536,34 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt = let get_type_of = pf_apply get_type_of gl in let t1 = get_type_of c1 and t2 = get_type_of c2 in - let is_conv = pf_apply is_conv gl in - if unsafe || (is_conv t1 t2) then + let evd = + if unsafe then Some (Proofview.Goal.sigma gl) + else + try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Proofview.Goal.sigma gl)) + with Evarconv.UnableToUnify _ -> None + in + match evd with + | None -> + tclFAIL 0 (str"Terms do not have convertible types.") + | Some evd -> let e = build_coq_eq () in let sym = build_coq_eq_sym () in + Tacticals.New.pf_constr_of_global e (fun e -> let eq = applist (e, [t1;c1;c2]) in if check_setoid clause then init_setoid (); - tclTHENS (assert_as false None eq) - [onLastHypId (fun id -> - tclTHEN - (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) - (clear [id])); - tclFIRST - [assumption; - tclTHEN (Proofview.V82.tactic (apply sym)) assumption; - try_prove_eq - ] - ] - else - tclFAIL 0 (str"Terms do not have convertible types.") + Tacticals.New.pf_constr_of_global sym (fun sym -> + tclTHENS (assert_as false None eq) + [onLastHypId (fun id -> + tclTHEN + (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) + (clear [id])); + tclFIRST + [assumption; + tclTHEN (Proofview.V82.tactic (apply sym)) assumption; + try_prove_eq + ] + ])) end let replace c2 c1 = multi_replace onConcl c2 c1 false None @@ -627,8 +637,7 @@ let find_positions env sigma t1 t2 = let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with - - | Construct sp1, Construct sp2 + | Construct (sp1,_), Construct (sp2,_) when Int.equal (List.length args1) (mis_constructor_nargs_env env sp1) -> let sorts = @@ -636,7 +645,7 @@ let find_positions env sigma t1 t2 = in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) - if is_conv env sigma hd1 hd2 then + if eq_constructor sp1 sp2 then let nrealargs = constructor_nrealargs env sp1 in let rargs1 = List.lastn nrealargs args1 in let rargs2 = List.lastn nrealargs args2 in @@ -746,7 +755,7 @@ let descend_then sigma env head dirn = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in - let ind,_ = dest_ind_family indf in + let (ind,_),_ = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in @@ -795,7 +804,7 @@ let construct_discriminator sigma env dirn c sort = errorlabstrm "Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in - let (ind,_) = dest_ind_family indf in + let ((ind,_),_) = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in let deparsign = make_arity_signature env true indf in @@ -847,22 +856,23 @@ let gen_absurdity id = *) let ind_scheme_of_eq lbeq = - let (mib,mip) = Global.lookup_inductive (destInd lbeq.eq) in + let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in let kind = inductive_sort_family mip in (* use ind rather than case by compatibility *) let kind = if kind == InProp then Elimschemes.ind_scheme_kind_from_prop else Elimschemes.ind_scheme_kind_from_type in - let c, eff = find_scheme kind (destInd lbeq.eq) in - mkConst c, eff + let c, eff = find_scheme kind (destIndRef lbeq.eq) in + ConstRef c, eff -let discrimination_pf e (t,t1,t2) discriminator lbeq = +let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = let i = build_coq_I () in let absurd_term = build_coq_False () in let eq_elim, eff = ind_scheme_of_eq lbeq in - (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), - eff + let sigma, eq_elim = Evd.fresh_global env sigma eq_elim in + sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), + eff let eq_baseid = Id.of_string "e" @@ -880,11 +890,12 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = let e_env = push_named (e,None,t) env in let discriminator = build_discriminator sigma e_env dirn (mkVar e) sort cpath in - let (pf, absurd_term), eff = - discrimination_pf e (t,t1,t2) discriminator lbeq in + let sigma,(pf, absurd_term), eff = + discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = clenv_value_cast_meta absurd_clause in + Proofview.V82.tclEVARS sigma <*> Proofview.tclEFFECTS eff <*> tclTHENS (cut_intro absurd_term) [onLastHypId gen_absurdity; (Proofview.V82.tactic (refine pf))] @@ -911,7 +922,7 @@ let onEquality with_evars tac (c,lbindc) = let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in let eq_clause' = clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in - let (eq,eq_args) = find_this_eq_data_decompose gl eqn in + let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in tclTHEN (Proofview.V82.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') @@ -964,7 +975,7 @@ let discrHyp id = discrClause false (onHyp id) constructor depending on the sort *) (* J.F.: correction du bug #1167 en accord avec Hugo. *) -let find_sigma_data s = build_sigma_type () +let find_sigma_data env s = build_sigma_type () (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser index bound in [rty] @@ -978,16 +989,18 @@ let find_sigma_data s = build_sigma_type () let make_tuple env sigma (rterm,rty) lind = assert (dependent (mkRel lind) rty); - let {intro = exist_term; typ = sig_term} = - find_sigma_data (get_sort_of env sigma rty) in + let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let a = type_of env sigma (mkRel lind) in let (na,_,_) = lookup_rel lind env in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) let p = mkLambda (na, a, rty) in - (applist(exist_term,[a;p;(mkRel lind);rterm]), - applist(sig_term,[a;p])) + let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in + let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in + sigma, + (applist(exist_term,[a;p;(mkRel lind);rterm]), + applist(sig_term,[a;p])) (* check that the free-references of the type of [c] are contained in the free-references of the normal-form of that type. Strictly @@ -1052,7 +1065,7 @@ let minimal_free_rels_rec env sigma = *) let sig_clausal_form env sigma sort_of_ty siglen ty dflt = - let { intro = exist_term } = find_sigma_data sort_of_ty in + let sigdata = find_sigma_data env sort_of_ty in let evdref = ref (Evd.create_goal_evar_defs sigma) in let rec sigrec_clausal_form siglen p_i = if Int.equal siglen 0 then @@ -1078,13 +1091,14 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = | Some w -> let w_type = type_of env sigma w in if Evarconv.e_cumul env evdref w_type a then + let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in applist(exist_term,[w_type;p_i_minus_1;w;tuple_tail]) else error "Cannot solve a unification problem." | None -> anomaly (Pp.str "Not enough components to build the dependent tuple") in let scf = sigrec_clausal_form siglen ty in - Evarutil.nf_evar !evdref scf + !evdref, Evarutil.nf_evar !evdref scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors @@ -1148,13 +1162,13 @@ let make_iterated_tuple env sigma dflt (z,zty) = let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in let sort_of_zty = get_sort_of env sigma zty in let sorted_rels = Int.Set.elements rels in - let (tuple,tuplety) = - List.fold_left (make_tuple env sigma) (z,zty) sorted_rels + let sigma, (tuple,tuplety) = + List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels in assert (closed0 tuplety); let n = List.length sorted_rels in - let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in - (tuple,tuplety,dfltval) + let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in + sigma, (tuple,tuplety,dfltval) let rec build_injrec sigma env dflt c = function | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c) @@ -1162,15 +1176,14 @@ let rec build_injrec sigma env dflt c = function try let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-argnum) in - let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in - (kont subval (dfltval,tuplety), - tuplety,dfltval) + let sigma, (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in + sigma, (kont subval (dfltval,tuplety), tuplety,dfltval) with UserError _ -> failwith "caught" let build_injector sigma env dflt c cpath = - let (injcode,resty,_) = build_injrec sigma env dflt c cpath in - (injcode,resty) + let sigma, (injcode,resty,_) = build_injrec sigma env dflt c cpath in + sigma, (injcode,resty) (* let try_delta_expand env sigma t = @@ -1199,28 +1212,32 @@ let simplify_args env sigma t = let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (e, None,t) env in + let evdref = ref sigma in let filter (cpath, t1', t2') = try (* arbitrarily take t1' as the injector default value *) - let (injbody,resty) = build_injector sigma e_env t1' (mkVar e) cpath in + let sigma, (injbody,resty) = build_injector !evdref e_env t1' (mkVar e) cpath in let injfun = mkNamedLambda e t injbody in - let pf = applist(eq.congr,[t;resty;injfun;t1;t2]) in - let pf_typ = get_type_of env sigma pf in + let congr = Evarutil.evd_comb1 (Evd.fresh_global env) evdref eq.congr in + let pf = applist(congr,[t;resty;injfun;t1;t2]) in + let sigma, pf_typ = Typing.e_type_of env sigma pf in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = clenv_value_cast_meta inj_clause in let ty = simplify_args env sigma (clenv_type inj_clause) in - Some (pf, ty) + evdref := sigma; + Some (pf, ty) with Failure _ -> None in let injectors = List.map_filter filter posns in if List.is_empty injectors then Proofview.tclZERO (Errors.UserError ("Equality.inj" , str "Failed to decompose the equality.")) else - Proofview.tclBIND + Proofview.tclTHEN (Proofview.V82.tclEVARS !evdref) + (Proofview.tclBIND (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [Proofview.tclUNIT (); Proofview.V82.tactic (refine pf)]) (if l2r then List.rev injectors else injectors)) - (fun _ -> tac (List.length injectors)) + (fun _ -> tac (List.length injectors))) exception Not_dep_pair @@ -1232,30 +1249,32 @@ let eqdep_dec = qualid_of_string "Coq.Logic.Eqdep_dec" let inject_if_homogenous_dependent_pair env sigma (eq,_,(t,t1,t2)) = Proofview.Goal.raw_enter begin fun gl -> (* fetch the informations of the pair *) - let ceq = constr_of_global Coqlib.glob_eq in + let ceq = Universes.constr_of_global Coqlib.glob_eq in let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in let eqTypeDest = fst (destApp t) in let _,ar1 = destApp t1 and _,ar2 = destApp t2 in let ind = destInd ar1.(0) in - (* check whether the equality deals with dep pairs or not *) - (* if yes, check if the user has declared the dec principle *) - (* and compare the fst arguments of the dep pair *) + (* check whether the equality deals with dep pairs or not *) + (* if yes, check if the user has declared the dec principle *) + (* and compare the fst arguments of the dep pair *) let new_eq_args = [|type_of env sigma ar1.(3);ar1.(3);ar2.(3)|] in - if (eq_constr eqTypeDest (sigTconstr())) && - (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind) && + if (Globnames.is_global (sigTconstr()) eqTypeDest) && + (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind)) && (is_conv env sigma ar1.(2) ar2.(2)) then begin Library.require_library [Loc.ghost,eqdep_dec] (Some false); let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in - let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in + let scheme, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in (* cut with the good equality and prove the requested goal *) tclTHENS (tclTHEN (Proofview.tclEFFECTS eff) (cut (mkApp (ceq,new_eq_args)))) - [tclIDTAC; tclTHEN (Proofview.V82.tactic (apply ( - mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3)|]) + [tclIDTAC; + pf_constr_of_global (ConstRef scheme) (fun c -> + tclTHEN (Proofview.V82.tactic (apply ( + mkApp(inj2,[|ar1.(0);c;ar1.(1);ar1.(2);ar1.(3);ar2.(3)|]) ))) (Auto.trivial [] []) - ] + )] (* not a dep eq or no decidable type found *) end else raise Not_dep_pair @@ -1341,29 +1360,31 @@ let swap_equality_args = function | HeterogenousEq (t1,e1,t2,e2) -> [t2;e2;t1;e1] let swap_equands eqn = - let (lbeq,eq_args) = find_eq_data eqn in - applist(lbeq.eq,swap_equality_args eq_args) + let (lbeq,u,eq_args) = find_eq_data eqn in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + applist(eq,swap_equality_args eq_args) let swapEquandsInConcl = Proofview.Goal.raw_enter begin fun gl -> - let (lbeq,eq_args) = find_eq_data (pf_nf_concl gl) in - let sym_equal = lbeq.sym in + let (lbeq,u,eq_args) = find_eq_data (pf_nf_concl gl) in let args = swap_equality_args eq_args @ [Evarutil.mk_new_meta ()] in - Proofview.V82.tactic (fun gl -> refine (applist (sym_equal, args)) gl) + pf_constr_of_global lbeq.sym (fun sym_equal -> + Proofview.V82.tactic (refine (applist (sym_equal, args)))) end (* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *) -let bareRevSubstInConcl lbeq body (t,e1,e2) = +let bareRevSubstInConcl (lbeq,u) body (t,e1,e2) = Proofview.Goal.raw_enter begin fun gl -> (* find substitution scheme *) - let eq_elim, effs = find_elim lbeq.eq (Some false) false None None gl in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + let eq_elim, effs = find_elim eq (Some false) false None None gl in (* build substitution predicate *) let p = lambda_create (Proofview.Goal.env gl) (t,body) in (* apply substitution scheme *) let args = [t; e1; p; Evarutil.mk_new_meta (); e2; Evarutil.mk_new_meta ()] in - let tac gl = refine (applist (eq_elim, args)) gl in - Proofview.V82.tactic tac + pf_constr_of_global (ConstRef eq_elim) (fun c -> + Proofview.V82.tactic (refine (applist (c, args)))) end (* [subst_tuple_term dep_pair B] @@ -1402,17 +1423,15 @@ let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = let iterated_decomp = try - let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in - let car_code = applist (p1,[a;p;inner_code]) - and cdr_code = applist (p2,[a;p;inner_code]) in + let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in + let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) + and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in let cdrtyp = beta_applist (p,[car]) in List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) with ConstrMatching.PatternMatchingFailure -> [] - in - [((ex,exty),inner_code)]::iterated_decomp - in - decomprec (mkRel 1) c t + in [((ex,exty),inner_code)]::iterated_decomp + in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let typ = get_type_of env sigma dep_pair1 in @@ -1435,7 +1454,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let expected_goal = beta_applist (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma expected_goal in - pred_body,expected_goal + pred_body,expected_goal (* Like "replace" but decompose dependent equalities *) @@ -1443,12 +1462,12 @@ exception NothingToRewrite let cutSubstInConcl_RL eqn = Proofview.Goal.raw_enter begin fun gl -> - let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in + let (lbeq,u,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in let concl = pf_nf_concl gl in let body,expected_goal = pf_apply subst_tuple_term gl e2 e1 concl in if not (dependent (mkRel 1) body) then raise NothingToRewrite; tclTHENFIRST - (bareRevSubstInConcl lbeq body eq) + (bareRevSubstInConcl (lbeq,u) body eq) (Proofview.V82.tactic (fun gl -> convert_concl expected_goal DEFAULTcast gl)) end @@ -1465,12 +1484,12 @@ let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL let cutSubstInHyp_LR eqn id = Proofview.Goal.enter begin fun gl -> - let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in + let (lbeq,u,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in let idtyp = pf_get_hyp_typ id gl in let body,expected_goal = pf_apply subst_tuple_term gl e1 e2 idtyp in if not (dependent (mkRel 1) body) then raise NothingToRewrite; let refine = Proofview.V82.tactic (fun gl -> Tacmach.refine_no_check (mkVar id) gl) in - let subst = Proofview.V82.of_tactic (tclTHENFIRST (bareRevSubstInConcl lbeq body eq) refine) in + let subst = Proofview.V82.of_tactic (tclTHENFIRST (bareRevSubstInConcl (lbeq,u) body eq) refine) in Proofview.V82.tactic (fun gl -> cut_replacing id expected_goal subst gl) end @@ -1555,8 +1574,8 @@ let unfold_body x = let restrict_to_eq_and_identity eq = (* compatibility *) - if not (eq_constr eq (constr_of_global glob_eq)) && - not (eq_constr eq (constr_of_global glob_identity)) + if not (is_global glob_eq eq) && + not (is_global glob_identity eq) then raise ConstrMatching.PatternMatchingFailure exception FoundHyp of (Id.t * constr * bool) @@ -1565,7 +1584,7 @@ exception FoundHyp of (Id.t * constr * bool) let is_eq_x gl x (id,_,c) = try let c = pf_nf_evar gl c in - let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in + let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); if (eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) with ConstrMatching.PatternMatchingFailure -> @@ -1664,8 +1683,9 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = try - let lbeq,(_,x,y) = find_eq_data_decompose c in - if flags.only_leibniz then restrict_to_eq_and_identity lbeq.eq; + let lbeq,u,(_,x,y) = find_eq_data_decompose c in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + if flags.only_leibniz then restrict_to_eq_and_identity eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if eq_constr x y then failwith "caught"; match kind_of_term x with Var x -> x | _ -> @@ -1684,19 +1704,19 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let cond_eq_term_left c t gl = try - let (_,x,_) = snd (find_eq_data_decompose gl t) in + let (_,x,_) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else failwith "not convertible" with ConstrMatching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try - let (_,_,x) = snd (find_eq_data_decompose gl t) in + let (_,_,x) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then false else failwith "not convertible" with ConstrMatching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try - let (_,x,y) = snd (find_eq_data_decompose gl t) in + let (_,x,y) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else if pf_conv_x gl c y then false else failwith "not convertible" diff --git a/tactics/equality.mli b/tactics/equality.mli index b59b4bbe0d..82e30b9401 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -88,7 +88,7 @@ val dEq : evars_flag -> constr with_bindings induction_arg option -> unit Proofv val dEqThen : evars_flag -> (constr -> int -> unit Proofview.tactic) -> constr with_bindings induction_arg option -> unit Proofview.tactic val make_iterated_tuple : - env -> evar_map -> constr -> (constr * types) -> constr * constr * constr + env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) (* The family cutRewriteIn expect an equality statement *) val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index f8790796d0..bda217566d 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -252,7 +252,14 @@ TACTIC EXTEND rewrite_star let add_rewrite_hint bases ort t lcsr = let env = Global.env() and sigma = Evd.empty in - let f c = Constrexpr_ops.constr_loc c, Constrintern.interp_constr sigma env c, ort, t in + let poly = Flags.is_universe_polymorphism () in + let f ce = + let c, ctx = Constrintern.interp_constr sigma env ce in + let ctx = + if poly then ctx + else (Global.add_constraints (snd ctx); Univ.ContextSet.empty) + in + Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in let eqs = List.map f lcsr in let add_hints base = add_rew_rules base eqs in List.iter add_hints bases @@ -281,8 +288,8 @@ open Coqlib let project_hint pri l2r r = let gr = Smartlocate.global_with_alias r in let env = Global.env() in - let c = Globnames.constr_of_global gr in - let t = Retyping.get_type_of env Evd.empty c in + let c,ctx = Universes.fresh_global_instance env gr in + let t = Retyping.get_type_of env (Evd.from_env ~ctx env) c in let t = Tacred.reduce_to_quantified_ref env Evd.empty (Lazy.force coq_iff_ref) t in let sign,ccl = decompose_prod_assum t in @@ -294,7 +301,11 @@ let project_hint pri l2r r = let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in let c = it_mkLambda_or_LetIn (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in - (pri,true,Auto.PathAny, Globnames.IsConstr c) + let id = + Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) + in + let c = Declare.declare_definition ~internal:Declare.KernelSilent id (c,ctx) in + (pri,false,true,Auto.PathAny, Auto.IsGlobRef (Globnames.ConstRef c)) let add_hints_iff l2r lc n bl = Auto.add_hints true bl @@ -473,7 +484,7 @@ let inTransitivity : bool * constr -> obj = (* Main entry points *) let add_transitivity_lemma left lem = - let lem' = Constrintern.interp_constr Evd.empty (Global.env ()) lem in + let lem',ctx (*FIXME*) = Constrintern.interp_constr Evd.empty (Global.env ()) lem in add_anonymous_leaf (inTransitivity (left,lem')) (* Vernacular syntax *) @@ -513,8 +524,8 @@ END VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> - [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in - let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in + [ let tc,ctx = Constrintern.interp_constr Evd.empty (Global.env ()) c in + let tb,ctx(*FIXME*) = Constrintern.interp_constr Evd.empty (Global.env ()) b in Global.register f tc tb ] END @@ -607,9 +618,11 @@ let hResolve id c occ t gl = let loc = match Loc.get_loc e with None -> Loc.ghost | Some loc -> loc in resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) in - let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in + let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in - change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl)) gl + tclTHEN (Refiner.tclEVARS sigma) + (change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl))) gl let hResolve_auto id c t gl = let rec resolve_auto n = @@ -749,6 +762,11 @@ TACTIC EXTEND constr_eq if eq_constr x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] END +TACTIC EXTEND constr_eq_nounivs +| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ + if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] +END + TACTIC EXTEND is_evar | [ "is_evar" constr(x) ] -> [ match kind_of_term x with @@ -772,6 +790,7 @@ let rec has_evar x = has_evar t1 || has_evar t2 || has_evar_array ts | Fix ((_, tr)) | CoFix ((_, tr)) -> has_evar_prec tr + | Proj (p, c) -> has_evar c and has_evar_array x = Array.exists has_evar x and has_evar_prec (_, ts1, ts2) = diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4 index 954892e81d..d00626d320 100644 --- a/tactics/g_rewrite.ml4 +++ b/tactics/g_rewrite.ml4 @@ -105,6 +105,12 @@ END let db_strat db = StratUnary ("topdown", StratHints (false, db)) let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) +let cl_rewrite_clause_db = + if Flags.profile then + let key = Profile.declare_profile "cl_rewrite_clause_db" in + Profile.profile3 key cl_rewrite_clause_db + else cl_rewrite_clause_db + TACTIC EXTEND rewrite_strat | [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s (Some id)) ] | [ "rewrite_strat" rewstrategy(s) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s None) ] @@ -140,21 +146,21 @@ TACTIC EXTEND setoid_rewrite [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))] END -let cl_rewrite_clause_newtac_tac c o occ cl = - cl_rewrite_clause_newtac' c o occ cl - -TACTIC EXTEND GenRew -| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> - [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] -| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> - [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] -| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> - [ cl_rewrite_clause_newtac_tac c o AllOccurrences (Some id) ] -| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> - [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) None ] -| [ "rew" orient(o) glob_constr_with_bindings(c) ] -> - [ cl_rewrite_clause_newtac_tac c o AllOccurrences None ] -END +(* let cl_rewrite_clause_newtac_tac c o occ cl = *) +(* cl_rewrite_clause_newtac' c o occ cl *) + +(* TACTIC EXTEND GenRew *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o AllOccurrences (Some id) ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) None ] *) +(* | [ "rew" orient(o) glob_constr_with_bindings(c) ] -> *) +(* [ cl_rewrite_clause_newtac_tac c o AllOccurrences None ] *) +(* END *) VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 89aaee485a..130e66720e 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -47,7 +47,7 @@ let match_with_non_recursive_type t = | App _ -> let (hdapp,args) = decompose_app t in (match kind_of_term hdapp with - | Ind ind -> + | Ind (ind,u) -> if not (Global.lookup_mind (fst ind)).mind_finite then Some (hdapp,args) else @@ -90,9 +90,9 @@ let match_with_one_constructor style onlybinary allow_rec t = let (hdapp,args) = decompose_app t in let res = match kind_of_term hdapp with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_inductive (fst ind) in if Int.equal (Array.length mip.mind_consnames) 1 - && (allow_rec || not (mis_is_recursive (ind,mib,mip))) + && (allow_rec || not (mis_is_recursive (fst ind,mib,mip))) && (Int.equal mip.mind_nrealargs 0) then if is_strict_conjunction style (* strict conjunction *) then @@ -137,8 +137,8 @@ let match_with_tuple t = let t = match_with_one_constructor None false true t in Option.map (fun (hd,l) -> let ind = destInd hd in - let (mib,mip) = Global.lookup_inductive ind in - let isrec = mis_is_recursive (ind,mib,mip) in + let (mib,mip) = Global.lookup_pinductive ind in + let isrec = mis_is_recursive (fst ind,mib,mip) in (hd,l,isrec)) t let is_tuple t = @@ -158,7 +158,7 @@ let test_strict_disjunction n lc = let match_with_disjunction ?(strict=false) ?(onlybinary=false) t = let (hdapp,args) = decompose_app t in let res = match kind_of_term hdapp with - | Ind ind -> + | Ind (ind,u) -> let car = mis_constr_nargs ind in let (mib,mip) = Global.lookup_inductive ind in if Array.for_all (fun ar -> Int.equal ar 1) car @@ -193,7 +193,7 @@ let match_with_empty_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 0 then Some hdapp else None | _ -> None @@ -207,7 +207,7 @@ let match_with_unit_or_eq_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in let zero_args c = Int.equal (nb_prod c) mib.mind_nparams in @@ -249,7 +249,7 @@ let match_with_equation t = if not (isApp t) then raise NoEquationFound; let (hdapp,args) = destApp t in match kind_of_term hdapp with - | Ind ind -> + | Ind (ind,u) -> if eq_gr (IndRef ind) glob_eq then Some (build_coq_eq_data()),hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) @@ -282,7 +282,7 @@ let is_inductive_equality ind = let match_with_equality_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind when is_inductive_equality ind -> Some (hdapp,args) + | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args) | _ -> None let is_equality_type t = op2bool (match_with_equality_type t) @@ -322,7 +322,7 @@ let match_with_nodep_ind t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in if Array.length (mib.mind_packets)>1 then None else let nodep_constr = has_nodep_prod_after mib.mind_nparams in if Array.for_all nodep_constr mip.mind_nf_lc then @@ -340,7 +340,7 @@ let match_with_sigma_type t= let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in if Int.equal (Array.length (mib.mind_packets)) 1 && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) && @@ -378,7 +378,7 @@ let match_eq eqn eq_pat = match Id.Map.bindings (matches pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); - PolymorphicLeibnizEq (t,x,y) + PolymorphicLeibnizEq (t,x,y) | [(m1,t);(m2,x);(m3,t');(m4,x')] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4); HeterogenousEq (t,x,t',x') @@ -387,13 +387,21 @@ let match_eq eqn eq_pat = let no_check () = true let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module +let build_coq_jmeq_data_in env = + build_coq_jmeq_data (), Univ.ContextSet.empty + +let build_coq_identity_data_in env = + build_coq_identity_data (), Univ.ContextSet.empty + let equalities = [coq_eq_pattern, no_check, build_coq_eq_data; coq_jmeq_pattern, check_jmeq_loaded, build_coq_jmeq_data; coq_identity_pattern, no_check, build_coq_identity_data] let find_eq_data eqn = (* fails with PatternMatchingFailure *) - first_match (match_eq eqn) equalities + let d,k = first_match (match_eq eqn) equalities in + let hd,u = destInd (fst (destApp eqn)) in + d,u,k let extract_eq_args gl = function | MonomorphicLeibnizEq (e1,e2) -> @@ -404,11 +412,11 @@ let extract_eq_args gl = function else raise PatternMatchingFailure let find_eq_data_decompose gl eqn = - let (lbeq,eq_args) = find_eq_data eqn in - (lbeq,extract_eq_args gl eq_args) + let (lbeq,u,eq_args) = find_eq_data eqn in + (lbeq,u,extract_eq_args gl eq_args) let find_this_eq_data_decompose gl eqn = - let (lbeq,eq_args) = + let (lbeq,u,eq_args) = try (*first_match (match_eq eqn) inversible_equalities*) find_eq_data eqn with PatternMatchingFailure -> @@ -417,7 +425,7 @@ let find_this_eq_data_decompose gl eqn = try extract_eq_args gl eq_args with PatternMatchingFailure -> error "Don't know what to do with JMeq on arguments not of same type." in - (lbeq,eq_args) + (lbeq,u,eq_args) let match_eq_nf gls eqn eq_pat = match Id.Map.bindings (pf_matches gls (Lazy.force eq_pat) eqn) with @@ -439,18 +447,16 @@ let coq_ex_pattern_gen ex = lazy PATTERN [ %ex ?X1 ?X2 ?X3 ?X4 ] let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref let coq_exist_pattern = coq_ex_pattern_gen coq_exist_ref -let match_sigma ex ex_pat = - match Id.Map.bindings (matches (Lazy.force ex_pat) ex) with - | [(m1,a);(m2,p);(m3,car);(m4,cdr)] -> - assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4); - (a,p,car,cdr) - | _ -> - anomaly ~label:"match_sigma" (Pp.str "a successful sigma pattern should match 4 terms") - +let match_sigma ex = + match kind_of_term ex with + | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_exist_ref) f -> + build_sigma (), (snd (destConstruct f), a, p, car, cdr) + | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_existT_ref) f -> + build_sigma_type (), (snd (destConstruct f), a, p, car, cdr) + | _ -> raise PatternMatchingFailure + let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) - first_match (match_sigma ex) - [coq_existT_pattern, no_check, build_sigma_type; - coq_exist_pattern, no_check, build_sigma] + match_sigma ex (* Pattern "(sig ?1 ?2)" *) let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ] @@ -495,7 +501,7 @@ let match_eqdec t = false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in match Id.Map.bindings subst with | [(_,typ);(_,c1);(_,c2)] -> - eqonleft, Globnames.constr_of_global (Lazy.force op), c1, c2, typ + eqonleft, Universes.constr_of_global (Lazy.force op), c1, c2, typ | _ -> anomaly (Pp.str "Unexpected pattern") (* Patterns "~ ?" and "? -> False" *) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index fc87fc9edf..3637be41d8 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -121,19 +121,19 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) val find_eq_data_decompose : 'a Proofview.Goal.t -> constr -> - coq_eq_data * (types * constr * constr) + coq_eq_data * Univ.universe_instance * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) val find_this_eq_data_decompose : 'a Proofview.Goal.t -> constr -> - coq_eq_data * (types * constr * constr) + coq_eq_data * Univ.universe_instance * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) -val find_eq_data : constr -> coq_eq_data * equation_kind +val find_eq_data : constr -> coq_eq_data * Univ.universe_instance * equation_kind (** Match a term of the form [(existT A P t p)] Returns associated lemmas and [A,P,t,p] *) val find_sigma_data_decompose : constr -> - coq_sigma_data * (constr * constr * constr * constr) + coq_sigma_data * (Univ.universe_instance * constr * constr * constr * constr) (** Match a term of the form [{x:A|P}], returns [A] and [P] *) val match_sigma : constr -> constr * constr diff --git a/tactics/inv.ml b/tactics/inv.ml index 0c0bcc06ac..0ff6b69a5c 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -67,7 +67,7 @@ type inversion_status = Dep of constr option | NoDep let compute_eqn env sigma n i ai = (mkRel (n-i),get_type_of env sigma (mkRel (n-i))) -let make_inv_predicate env sigma indf realargs id status concl = +let make_inv_predicate env evd indf realargs id status concl = let nrealargs = List.length realargs in let (hyps,concl) = match status with @@ -86,11 +86,12 @@ let make_inv_predicate env sigma indf realargs id status concl = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> - let sort = get_sort_family_of env sigma concl in - let p = make_arity env true indf (new_sort_in_family sort) in - fst (Unification.abstract_list_all env - (Evd.create_evar_defs sigma) - p concl (realargs@[mkVar id])) in + let sort = get_sort_family_of env !evd concl in + let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in + let p = make_arity env true indf sort in + let evd',(p,ptyp) = Unification.abstract_list_all env + !evd p concl (realargs@[mkVar id]) + in evd := evd'; p in let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) @@ -102,21 +103,25 @@ let make_inv_predicate env sigma indf realargs id status concl = (* Now, we can recurse down this list, for each ai,(mkRel k) whether to push <Ai>(mkRel k)=ai (when Ai is closed). In any case, we carry along the rest of pairs *) + let eqdata = Coqlib.build_coq_eq_data () in let rec build_concl eqns args n = function | [] -> it_mkProd concl eqns, Array.rev_of_list args | ai :: restlist -> let ai = lift nhyps ai in - let (xi, ti) = compute_eqn env' sigma nhyps n ai in + let (xi, ti) = compute_eqn env' !evd nhyps n ai in let (lhs,eqnty,rhs) = if closed0 ti then (xi,ti,ai) else - make_iterated_tuple env' sigma ai (xi,ti) + let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in + evd := sigma; res in - let eq_term = Coqlib.build_coq_eq () in - let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in + let eq_term = eqdata.Coqlib.eq in + let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in + let eqn = applist (eq,[eqnty;lhs;rhs]) in let eqns = (Anonymous, lift n eqn) :: eqns in - let refl_term = Coqlib.build_coq_eq_refl () in + let refl_term = eqdata.Coqlib.refl in + let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in let args = refl :: args in build_concl eqns args (succ n) restlist @@ -455,8 +460,10 @@ let raw_inversion inv_kind id status names = Errors.errorlabstrm "" msg in let IndType (indf,realargs) = find_rectype env sigma t in + let evdref = ref sigma in let (elim_predicate, args) = - make_inv_predicate env sigma indf realargs id status concl in + make_inv_predicate env evdref indf realargs id status concl in + let sigma = !evdref in let (cut_concl,case_tac) = if status != NoDep && (dependent c concl) then Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), @@ -470,12 +477,13 @@ let raw_inversion inv_kind id status names = Proofview.Refine.refine (fun h -> h, prf) in let neqns = List.length realargs in - tclTHENS + tclTHEN (Proofview.V82.tclEVARS sigma) + (tclTHENS (assert_tac Anonymous cut_concl) [case_tac names (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns)) (Some elim_predicate) ind (c, t); - onLastHypId (fun id -> tclTHEN (refined id) reflexivity)] + onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) end (* Error messages of the inversion tactics *) @@ -486,7 +494,7 @@ let wrap_inv_error id = function (strbrk "Inversion would require case analysis on sort " ++ pr_sort k ++ strbrk " which is not allowed for inductive definition " ++ - pr_inductive (Global.env()) i ++ str "."))) + pr_inductive (Global.env()) (fst i) ++ str "."))) | e -> Proofview.tclZERO e (* The most general inversion tactic *) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 5e5de2589c..23a7c9e532 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -194,7 +194,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = errorlabstrm "lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) - let pf = Proof.start Evd.empty [invEnv,invGoal] in + let pf = Proof.start Evd.empty [invEnv,(invGoal,get_universe_context_set sigma)] in let pf = fst (Proof.run_tactic env ( tclTHEN intro (onLastHypId inv_op)) pf) @@ -232,6 +232,9 @@ let add_inversion_lemma name env sigma t sort dep inv_op = const_entry_body = Future.from_val (invProof,Declareops.no_seff); const_entry_secctx = None; const_entry_type = None; + const_entry_proj = None; + const_entry_polymorphic = true; + const_entry_universes = Univ.UContext.empty (*FIXME *); const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -244,8 +247,9 @@ let add_inversion_lemma name env sigma t sort dep inv_op = let add_inversion_lemma_exn na com comsort bool tac = let env = Global.env () and sigma = Evd.empty in - let c = Constrintern.interp_type sigma env com in - let sort = Pretyping.interp_sort comsort in + let c,ctx = Constrintern.interp_type sigma env com in + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in + let sigma, sort = Pretyping.interp_sort sigma comsort in try add_inversion_lemma na env sigma c sort bool tac with @@ -260,7 +264,7 @@ let lemInv id c gls = try let clause = mk_clenv_type_of gls c in let clause = clenv_constrain_last_binding (mkVar id) clause in - Clenvtac.res_pf clause ~flags:Unification.elim_flags gls + Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) gls with | NoSuchBinding -> errorlabstrm "" diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml new file mode 100644 index 0000000000..b07aff99b2 --- /dev/null +++ b/tactics/nbtermdn.ml @@ -0,0 +1,131 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Term +open Pattern +open Globnames + +(* Named, bounded-depth, term-discrimination nets. + Implementation: + Term-patterns are stored in discrimination-nets, which are + themselves stored in a hash-table, indexed by the first label. + They are also stored by name in a table on-the-side, so that we can + override them if needed. *) + +(* The former comments are from Chet. + See the module dn.ml for further explanations. + Eduardo (5/8/97) *) +module Make = + functor (Y:Map.OrderedType) -> +struct + module X = struct + type t = constr_pattern*int + let compare = Pervasives.compare + end + + module Term_dn = Termdn.Make(Y) + open Term_dn + module Z = struct + type t = Term_dn.term_label + let compare x y = + let make_name n = + match n with + | GRLabel(ConstRef con) -> + GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | GRLabel(IndRef (kn,i)) -> + GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | GRLabel(ConstructRef ((kn,i),j ))-> + GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + module Dn = Dn.Make(X)(Z)(Y) + module Bounded_net = Btermdn.Make(Y) + + +type 'na t = { + mutable table : ('na,constr_pattern * Y.t) Gmap.t; + mutable patterns : (Term_dn.term_label option,Bounded_net.t) Gmap.t } + + +type 'na frozen_t = + ('na,constr_pattern * Y.t) Gmap.t + * (Term_dn.term_label option, Bounded_net.t) Gmap.t + +let create () = + { table = Gmap.empty; + patterns = Gmap.empty } + +let get_dn dnm hkey = + try Gmap.find hkey dnm with Not_found -> Bounded_net.create () + +let add dn (na,(pat,valu)) = + let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in + dn.table <- Gmap.add na (pat,valu) dn.table; + let dnm = dn.patterns in + dn.patterns <- Gmap.add hkey (Bounded_net.add None (get_dn dnm hkey) (pat,valu)) dnm + +let rmv dn na = + let (pat,valu) = Gmap.find na dn.table in + let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in + dn.table <- Gmap.remove na dn.table; + let dnm = dn.patterns in + dn.patterns <- Gmap.add hkey (Bounded_net.rmv None (get_dn dnm hkey) (pat,valu)) dnm + +let in_dn dn na = Gmap.mem na dn.table + +let remap ndn na (pat,valu) = + rmv ndn na; + add ndn (na,(pat,valu)) + +let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] + + let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Const _ -> Dn.Everything + | _ -> Dn.Nothing + +let lookup dn valu = + let hkey = + match (constr_val_discr valu) with + | Dn.Label(l,_) -> Some l + | _ -> None + in + try Bounded_net.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> [] + +let app f dn = Gmap.iter f dn.table + +let dnet_depth = Btermdn.dnet_depth + +let freeze dn = (dn.table, dn.patterns) + +let unfreeze (fnm,fdnm) dn = + dn.table <- fnm; + dn.patterns <- fdnm + +let empty dn = + dn.table <- Gmap.empty; + dn.patterns <- Gmap.empty + +let to2lists dn = + (Gmap.to_list dn.table, Gmap.to_list dn.patterns) +end diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index ae73d7a41e..83cb15f47e 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Names +open Pp open Errors open Util open Nameops @@ -32,91 +34,86 @@ open Decl_kinds open Elimschemes open Goal open Environ -open Pp -open Names open Tacinterp open Termops +open Genarg +open Extraargs +open Pcoq.Constr open Entries open Libnames +open Evarutil (** Typeclass-based generalized rewriting. *) (** Constants used by the tactic. *) let classes_dirpath = - DirPath.make (List.map Id.of_string ["Classes";"Coq"]) + Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"]) let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] -let get_class str = - let qualid = Qualid (Loc.ghost, qualid_of_string str) in - lazy (class_info (Nametab.global qualid)) - -let proper_class = get_class "Coq.Classes.Morphisms.Proper" -let proper_proxy_class = get_class "Coq.Classes.Morphisms.ProperProxy" - -let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) - let make_dir l = DirPath.make (List.rev_map Id.of_string l) let try_find_global_reference dir s = let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in Nametab.global_of_path sp -let try_find_reference dir s = - constr_of_global (try_find_global_reference dir s) +let find_reference dir s = + let gr = lazy (try_find_global_reference dir s) in + fun () -> Lazy.force gr -let gen_constant dir s = Coqlib.gen_constant "rewrite" dir s -let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq") -let coq_f_equal = lazy (gen_constant ["Init"; "Logic"] "f_equal") -let coq_all = lazy (gen_constant ["Init"; "Logic"] "all") -let coq_forall = lazy (gen_constant ["Classes"; "Morphisms"] "forall_def") -let impl = lazy (gen_constant ["Program"; "Basics"] "impl") -let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow") +type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) -let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive") -let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity") +let find_global dir s = + let gr = lazy (try_find_global_reference dir s) in + fun (evd,cstrs) -> + let evd, c = Evarutil.new_global evd (Lazy.force gr) in + (evd, cstrs), c -let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric") -let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry") +(** Utility for dealing with polymorphic applications *) -let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive") -let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity") +let app_poly evars f args = + let evars, fc = f evars in + evars, mkApp (fc, args) -let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") +let e_app_poly evars f args = + let evars', c = app_poly !evars f args in + evars := evars'; + c -let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) +(** Global constants. *) -let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") -let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") -let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") -let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") -let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") -let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") -let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") -let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") -let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) -let rewrite_relation_class = lazy (gen_constant ["Classes"; "RelationClasses"] "RewriteRelation") +let gen_reference dir s = Coqlib.gen_reference "rewrite" dir s +let coq_eq_ref = find_reference ["Init"; "Logic"] "eq" +let coq_eq = find_global ["Init"; "Logic"] "eq" +let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" +let coq_all = find_global ["Init"; "Logic"] "all" +let impl = find_global ["Program"; "Basics"] "impl" +let arrow = find_global ["Program"; "Basics"] "arrow" +let coq_inverse = find_global ["Program"; "Basics"] "flip" -let proper_type = lazy (constr_of_global (Lazy.force proper_class).cl_impl) -let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).cl_impl) +(* let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") *) -(** Utility functions *) +(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) *) -let split_head = function - hd :: tl -> hd, tl - | [] -> assert(false) +(* let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") *) +(* let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") *) +(* let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") *) +(* let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") *) +(* let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") *) +(* let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") *) +(* let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") *) +(* let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") *) +(* let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) *) -let evd_convertible env evd x y = - try ignore(Evarconv.the_conv_x env x y evd); true - with e when Errors.noncritical e -> false +(* let proper_type = lazy (Universes.constr_of_global (Lazy.force proper_class).cl_impl) *) +(* let proper_proxy_type = lazy (Universes.constr_of_global (Lazy.force proper_proxy_class).cl_impl) *) -let convertible env evd x y = - Reductionops.is_conv env evd x y -(** Bookkeeping which evars are constraints so that we can + +(** Bookkeeping which evars are constraints so that we can remove them at the end of the tactic. *) let goalevars evars = fst evars @@ -127,10 +124,17 @@ let new_cstr_evar (evd,cstrs) env t = (evd', Evar.Set.add (fst (destEvar t)) cstrs), t (** Building or looking up instances. *) +let e_new_cstr_evar evars env t = + let evd', t = new_cstr_evar !evars env t in evars := evd'; t + +let new_goal_evar (evd,cstrs) env t = + let evd', t = Evarutil.new_evar evd env t in + (evd', cstrs), t + +let e_new_goal_evar evars env t = + let evd', t = new_goal_evar !evars env t in evars := evd'; t -let proper_proof env evars carrier relation x = - let goal = mkApp (Lazy.force proper_proxy_type, [| carrier ; relation; x |]) - in new_cstr_evar evars env goal +(** Building or looking up instances. *) let extends_undefined evars evars' = let f ev evi found = found || not (Evd.mem evars ev) @@ -138,95 +142,328 @@ let extends_undefined evars evars' = let find_class_proof proof_type proof_method env evars carrier relation = try - let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in - let evars', c = Typeclasses.resolve_one_typeclass env evars goal in - if extends_undefined evars evars' then raise Not_found - else mkApp (Lazy.force proof_method, [| carrier; relation; c |]) + let evars, goal = app_poly evars proof_type [| carrier ; relation |] in + let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in + if extends_undefined (goalevars evars) evars' then raise Not_found + else app_poly (evars',cstrevars evars) proof_method [| carrier; relation; c |] with e when Logic.catchable_exception e -> raise Not_found + +(** Utility functions *) -let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env -let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env -let get_transitive_proof env = find_class_proof transitive_type transitive_proof env - -(** Build an infered signature from constraints on the arguments and expected output - relation *) - -let build_signature evars env m (cstrs : (types * types option) option list) - (finalcstr : (types * types option) option) = - let mk_relty evars newenv ty obj = - match obj with +module GlobalBindings (M : sig + val relation_classes : string list + val morphisms : string list + val relation : string list * string +end) = struct + open M + let relation : evars -> evars * constr = find_global (fst relation) (snd relation) + + let reflexive_type = find_global relation_classes "Reflexive" + let reflexive_proof = find_global relation_classes "reflexivity" + + let symmetric_type = find_global relation_classes "Symmetric" + let symmetric_proof = find_global relation_classes "symmetry" + + let transitive_type = find_global relation_classes "Transitive" + let transitive_proof = find_global relation_classes "transitivity" + + let forall_relation = find_global morphisms "forall_relation" + let pointwise_relation = find_global morphisms "pointwise_relation" + + let forall_relation_ref = find_reference morphisms "forall_relation" + let pointwise_relation_ref = find_reference morphisms "pointwise_relation" + + let respectful = find_global morphisms "respectful" + let respectful_ref = find_reference morphisms "respectful" + + let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" + + let coq_forall = find_global morphisms "forall_def" + + let subrelation = find_global relation_classes "subrelation" + let do_subrelation = find_global morphisms "do_subrelation" + let apply_subrelation = find_global morphisms "apply_subrelation" + + let rewrite_relation_class = find_global relation_classes "RewriteRelation" + + let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper")) + let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy")) + + let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) + + let proper_type = + let l = lazy (Lazy.force proper_class).cl_impl in + fun (evd,cstrs) -> + let evd, c = Evarutil.new_global evd (Lazy.force l) in + (evd, cstrs), c + + let proper_proxy_type = + let l = lazy (Lazy.force proper_proxy_class).cl_impl in + fun (evd,cstrs) -> + let evd, c = Evarutil.new_global evd (Lazy.force l) in + (evd, cstrs), c + + let proper_proof env evars carrier relation x = + let evars, goal = app_poly evars proper_proxy_type [| carrier ; relation; x |] in + new_cstr_evar evars env goal + + let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env + let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env + let get_transitive_proof env = find_class_proof transitive_type transitive_proof env + + let mk_relation evd a = + app_poly evd relation [| a |] + + (** Build an infered signature from constraints on the arguments and expected output + relation *) + + let build_signature evars env m (cstrs : (types * types option) option list) + (finalcstr : (types * types option) option) = + let mk_relty evars newenv ty obj = + match obj with | None | Some (_, None) -> - let relty = mk_relation ty in - if closed0 ty then - let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in - new_cstr_evar evars env' relty - else new_cstr_evar evars newenv relty + let evars, relty = mk_relation evars ty in + if closed0 ty then + let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in + new_cstr_evar evars env' relty + else new_cstr_evar evars newenv relty | Some (x, Some rel) -> evars, rel - in - let rec aux env evars ty l = - let t = Reductionops.whd_betadeltaiota env (fst evars) ty in - match kind_of_term t, l with - | Prod (na, ty, b), obj :: cstrs -> + in + let rec aux env evars ty l = + let t = Reductionops.whd_betadeltaiota env (goalevars evars) ty in + match kind_of_term t, l with + | Prod (na, ty, b), obj :: cstrs -> if noccurn 1 b (* non-dependent product *) then - let ty = Reductionops.nf_betaiota (fst evars) ty in + let ty = Reductionops.nf_betaiota (goalevars evars) ty in let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in let evars, relty = mk_relty evars env ty obj in - let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in + let evars, newarg = app_poly evars respectful [| ty ; b' ; relty ; arg |] in evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs else - let (evars, b, arg, cstrs) = aux (Environ.push_rel (na, None, ty) env) evars b cstrs in - let ty = Reductionops.nf_betaiota (fst evars) ty in + let (evars, b, arg, cstrs) = + aux (Environ.push_rel (na, None, ty) env) evars b cstrs + in + let ty = Reductionops.nf_betaiota (goalevars evars) ty in let pred = mkLambda (na, ty, b) in let liftarg = mkLambda (na, ty, arg) in - let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in + let evars, arg' = app_poly evars forall_relation [| ty ; pred ; liftarg |] in if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs else error "build_signature: no constraint can apply on a dependent argument" - | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") - | _, [] -> + | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") + | _, [] -> (match finalcstr with | None | Some (_, None) -> - let t = Reductionops.nf_betaiota (fst evars) ty in - let evars, rel = mk_relty evars env t None in - evars, t, rel, [t, Some rel] + let t = Reductionops.nf_betaiota (fst evars) ty in + let evars, rel = mk_relty evars env t None in + evars, t, rel, [t, Some rel] | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) - in aux env evars m cstrs + in aux env evars m cstrs -type hypinfo = { - cl : clausenv; - ext : Evar.Set.t; (* New evars in this clausenv *) - prf : constr; - car : constr; - rel : constr; - c1 : constr; - c2 : constr; - c : (Tacinterp.interp_sign * Tacexpr.glob_constr_and_expr with_bindings) option; - abs : bool; -} + (** Folding/unfolding of the tactic constants. *) + + let unfold_impl t = + match kind_of_term t with + | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> + mkProd (Anonymous, a, lift 1 b) + | _ -> assert false + + let unfold_all t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let unfold_forall t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let arrow_morphism evd ta tb a b = + let ap = is_Prop ta and bp = is_Prop tb in + if ap && bp then app_poly evd impl [| a; b |], unfold_impl + else if ap then (* Domain in Prop, CoDomain in Type *) + (evd, mkProd (Anonymous, a, b)), (fun x -> x) + else if bp then (* Dummy forall *) + (app_poly evd coq_all [| a; mkLambda (Anonymous, a, b) |]), unfold_forall + else (* None in Prop, use arrow *) + (app_poly evd arrow [| a; b |]), unfold_impl + + let rec decomp_pointwise n c = + if Int.equal n 0 then c + else + match kind_of_term c with + | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> + decomp_pointwise (pred n) relb + | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> + decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) + | _ -> invalid_arg "decomp_pointwise" + + let rec apply_pointwise rel = function + | arg :: args -> + (match kind_of_term rel with + | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> + apply_pointwise relb args + | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> + apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args + | _ -> invalid_arg "apply_pointwise") + | [] -> rel + + let pointwise_or_dep_relation evd n t car rel = + if noccurn 1 car && noccurn 1 rel then + app_poly evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] + else + app_poly evd forall_relation + [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] + + let lift_cstr env evars (args : constr list) c ty cstr = + let start evars env car = + match cstr with + | None | Some (_, None) -> + let evars, rel = mk_relation evars car in + new_cstr_evar evars env rel + | Some (ty, Some rel) -> evars, rel + in + let rec aux evars env prod n = + if Int.equal n 0 then start evars env prod + else + match kind_of_term (Reduction.whd_betadeltaiota env prod) with + | Prod (na, ty, b) -> + if noccurn 1 b then + let b' = lift (-1) b in + let evars, rb = aux evars env b' (pred n) in + app_poly evars pointwise_relation [| ty; b'; rb |] + else + let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in + app_poly evars forall_relation + [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] + | _ -> raise Not_found + in + let rec find env c ty = function + | [] -> None + | arg :: args -> + try let evars, found = aux evars env ty (succ (List.length args)) in + Some (evars, found, c, ty, arg :: args) + with Not_found -> + find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args + in find env c ty args + + let unlift_cstr env sigma = function + | None -> None + | Some codom -> Some (decomp_pointwise 1 codom) + +end + +(* let my_type_of env evars c = Typing.e_type_of env evars c *) +(* let mytypeofkey = Profile.declare_profile "my_type_of";; *) +(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *) + + +let type_app_poly env evd f args = + let evars, c = app_poly evd f args in + let evd', t = Typing.e_type_of env (goalevars evars) c in + (evd', cstrevars evars), c + +module PropGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "RelationClasses"] + let morphisms = ["Classes"; "Morphisms"] + let relation = ["Relations";"Relation_Definitions"], "relation" + end + + module G = GlobalBindings(Consts) + + include G + include Consts + let inverse env evd car rel = + type_app_poly env evd coq_inverse [| car ; car; mkProp; rel |] + (* app_poly evd coq_inverse [| car ; car; mkProp; rel |] *) + +end + +module TypeGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "CRelationClasses"] + let morphisms = ["Classes"; "CMorphisms"] + let relation = relation_classes, "crelation" + end + + module G = GlobalBindings(Consts) + include G + + + let inverse env (evd,cstrs) car rel = + let evd, (sort,_) = Evarutil.new_type_evar Evd.univ_flexible evd env in + app_poly (evd,cstrs) coq_inverse [| car ; car; sort; rel |] + +end + +let sort_of_rel env evm rel = + Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel) (** Looking up declared rewrite relations (instances of [RewriteRelation]) *) let is_applied_rewrite_relation env sigma rels t = match kind_of_term t with | App (c, args) when Array.length args >= 2 -> let head = if isApp c then fst (destApp c) else c in - if eq_constr (Lazy.force coq_eq) head then None + if Globnames.is_global (coq_eq_ref ()) head then None else (try let params, args = Array.chop (Array.length args - 2) args in let env' = Environ.push_rel_context rels env in - let evd, evar = Evarutil.new_evar sigma env' (new_Type ()) in - let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in - let _ = Typeclasses.resolve_one_typeclass env' evd inst in + let evars, (evar, _) = Evarutil.new_type_evar Evd.univ_flexible sigma env' in + let evars, inst = + app_poly (evars,Evar.Set.empty) + TypeGlobal.rewrite_relation_class [| evar; mkApp (c, params) |] in + let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in Some (it_mkProd_or_LetIn t rels) with e when Errors.noncritical e -> None) | _ -> None -let rec decompose_app_rel env evd t = +(* let _ = *) +(* Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *) + +let split_head = function + hd :: tl -> hd, tl + | [] -> assert(false) + +let evd_convertible env evd x y = + try ignore(Evarconv.the_conv_x env x y evd); true + with e when Errors.noncritical e -> false + +let convertible env evd x y = + Reductionops.is_conv env evd x y + +type hypinfo = { + cl : clausenv; + prf : constr; + car : constr; + rel : constr; + sort : bool; (* true = Prop; false = Type *) + l2r : bool; + c1 : constr; + c2 : constr; + c : (Tacinterp.interp_sign * Tacexpr.glob_constr_and_expr with_bindings) option; + abs : (constr * types) option; + flags : Unification.unify_flags; +} + +let get_symmetric_proof b = + if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof + +let rec decompose_app_rel env evd t = match kind_of_term t with - | App (f, args) -> - if Array.length args > 1 then + | App (f, args) -> + if Array.length args > 1 then let fargs, args = Array.chop (Array.length args - 2) args in mkApp (f, fargs), args - else + else let (f', args) = decompose_app_rel env evd args.(0) in let ty = Typing.type_of env evd args.(0) in let f'' = mkLambda (Name (Id.of_string "x"), ty, @@ -235,37 +472,46 @@ let rec decompose_app_rel env evd t = in (f'', args) | _ -> error "The term provided is not an applied relation." -let decompose_applied_relation env sigma orig (c,l) = - let ctype = Typing.type_of env sigma c in +let decompose_applied_relation env origsigma sigma flags orig (c,l) left2right = + let c' = c in + let ctype = Typing.type_of env sigma c' in let find_rel ty = - let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c, ty) l in + let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in let (equiv, args) = decompose_app_rel env eqclause.evd (Clenv.clenv_type eqclause) in - let c1 = args.(0) and c2 = args.(1) in + let c1 = args.(0) and c2 = args.(1) in let ty1, ty2 = Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2 in if not (evd_convertible env eqclause.evd ty1 ty2) then None else + let sort = sort_of_rel env eqclause.evd equiv in let value = Clenv.clenv_value eqclause in - let ext = Evarutil.evars_of_term value in - Some { cl=eqclause; ext=ext; prf=value; - car=ty1; rel = equiv; c1=c1; c2=c2; c=orig; abs=false; } + let eqclause = { eqclause with evd = Evd.diff eqclause.evd origsigma } in + Some { cl=eqclause; prf=value; + car=ty1; rel = equiv; sort = Sorts.is_prop sort; + l2r=left2right; c1=c1; c2=c2; c=orig; abs=None; + flags = flags } in match find_rel ctype with | Some c -> c | None -> - let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' ctx) with + let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> n, None, t) ctx)) with | Some c -> c | None -> error "The term does not end with an applied homogeneous relation." -let decompose_applied_relation_expr env sigma (is, (c,l)) = - let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in - decompose_applied_relation env sigma (Some (is, (c,l))) cbl +let decompose_applied_relation_expr env sigma flags (is, (c,l)) left2right = + let sigma', cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in + decompose_applied_relation env sigma sigma' flags (Some (is, (c,l))) cbl left2right + +let rewrite_db = "rewrite" -(** Hint database named "rewrite", now created directly in Auto *) +let conv_transparent_state = (Id.Pred.empty, Cpred.full) -let rewrite_db = Auto.rewrite_db +let _ = + Auto.add_auto_init + (fun () -> + Auto.create_hint_db false rewrite_db conv_transparent_state true) let rewrite_transparent_state () = Auto.Hint_db.transparent_state (Auto.searchtable_map rewrite_db) @@ -288,10 +534,10 @@ let rewrite_unif_flags = { } let rewrite2_unif_flags = - { Unification.modulo_conv_on_closed_terms = Some cst_full_transparent_state; + { Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; - Unification.modulo_delta_types = cst_full_transparent_state; + Unification.modulo_delta_types = conv_transparent_state; Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = false; @@ -304,7 +550,7 @@ let rewrite2_unif_flags = Unification.allow_K_in_toplevel_higher_order_unification = true } -let general_rewrite_unif_flags () = +let general_rewrite_unif_flags () = let ts = rewrite_transparent_state () in { Unification.modulo_conv_on_closed_terms = Some ts; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; @@ -322,13 +568,14 @@ let general_rewrite_unif_flags () = Unification.allow_K_in_toplevel_higher_order_unification = true } let refresh_hypinfo env sigma hypinfo = - let {c=c} = hypinfo in + if Option.is_empty hypinfo.abs then + let {l2r=l2r; c=c;cl=cl;flags=flags} = hypinfo in match c with | Some c -> (* Refresh the clausenv to not get the same meta twice in the goal. *) - decompose_applied_relation_expr env sigma c + decompose_applied_relation_expr env sigma flags c l2r; | _ -> hypinfo - + else hypinfo let solve_remaining_by by env prf = match by with @@ -336,10 +583,10 @@ let solve_remaining_by by env prf = | Some tac -> let indep = clenv_independent env in let tac = eval_tactic tac in - let evd' = + let evd' = List.fold_right (fun mv evd -> let ty = Clenv.clenv_nf_meta env (meta_type evd mv) in - let c,_ = Pfedit.build_by_tactic env.env ty (Tacticals.New.tclCOMPLETE tac) in + let c,_,_ = Pfedit.build_by_tactic env.env (ty,Univ.ContextSet.empty) (Tacticals.New.tclCOMPLETE tac) in meta_assign mv (c, (Conv,TypeNotProcessed)) evd) indep env.evd in { env with evd = evd' }, prf @@ -352,35 +599,32 @@ let extend_evd sigma ext sigma' = let shrink_evd sigma ext = Evar.Set.fold (fun i acc -> Evd.remove acc i) ext sigma -let no_constraints cstrs = +let no_constraints cstrs = fun ev _ -> not (Evar.Set.mem ev cstrs) -let eq_env x y = x == y +let poly_inverse sort = + if sort then PropGlobal.inverse else TypeGlobal.inverse -let unify_eqn l2r flags env (sigma, cstrs) hypinfo by t = +let unify_eqn env (sigma, cstrs) hypinfo by t = if isEvar t then None else try - let hypinfo = - if hypinfo.abs || eq_env hypinfo.cl.env env then hypinfo - else refresh_hypinfo env sigma hypinfo - in - let {cl=cl; ext=ext; prf=prf; car=car; rel=rel; c1=c1; c2=c2; abs=abs} = - hypinfo in + let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = + !hypinfo in let left = if l2r then c1 else c2 in - let evd' = Evd.evars_reset_evd ~with_conv_pbs:true sigma cl.evd in - let evd'' = extend_evd evd' ext cl.evd in - let cl = { cl with evd = evd'' } in - let hypinfo, evd', prf, c1, c2, car, rel = - if abs then + let evd' = Evd.merge sigma cl.evd in + let cl = { cl with evd = evd' } in + let evd', prf, c1, c2, car, rel = + match abs with + | Some (absprf, absprfty) -> let env' = clenv_unify ~flags:rewrite_unif_flags CONV left t cl in - hypinfo, env'.evd, prf, c1, c2, car, rel - else - let env' = clenv_unify ~flags CONV left t cl in + env'.evd, prf, c1, c2, car, rel + | None -> + let env' = clenv_unify ~flags:!hypinfo.flags CONV left t cl in let env' = Clenvtac.clenv_pose_dependent_evars true env' in let evd' = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) ~fail:true env'.env env'.evd in let env' = { env' with evd = evd' } in - let env', prf = solve_remaining_by by env' (Clenv.clenv_value env') in + let env', prf = solve_remaining_by by env' (Clenv.clenv_value env') in let nf c = Evarutil.nf_evar env'.evd (Clenv.clenv_nf_meta env' c) in let c1 = nf c1 and c2 = nf c2 and car = nf car and rel = nf rel @@ -388,131 +632,41 @@ let unify_eqn l2r flags env (sigma, cstrs) hypinfo by t = let ty1 = Typing.type_of env'.env env'.evd c1 and ty2 = Typing.type_of env'.env env'.evd c2 in - if convertible env env'.evd ty1 ty2 then + if convertible env env'.evd ty1 ty2 then (if occur_meta_or_existential prf then - let hypinfo = refresh_hypinfo env env'.evd hypinfo in - (hypinfo, env'.evd, prf, c1, c2, car, rel) + (hypinfo := refresh_hypinfo env env'.evd !hypinfo; + env'.evd, prf, c1, c2, car, rel) else (** Evars have been solved, we can go back to the initial evd, but keep the potential refinement of existing evars. *) - let evd' = shrink_evd env'.evd ext in - (hypinfo, evd', prf, c1, c2, car, rel)) + env'.evd, prf, c1, c2, car, rel) else raise Reduction.NotConvertible in - let res = - if l2r then (prf, (car, rel, c1, c2)) + let evars = evd', Evar.Set.empty in + let evd, res = + if l2r then evars, (prf, (car, rel, c1, c2)) else - try (mkApp (get_symmetric_proof env evd' car rel, - [| c1 ; c2 ; prf |]), - (car, rel, c2, c1)) + try + let evars, symprf = get_symmetric_proof !hypinfo.sort env evars car rel in + evars, (mkApp (symprf, [| c1 ; c2 ; prf |]), + (car, rel, c2, c1)) with Not_found -> - (prf, (car, inverse car rel, c2, c1)) - in Some (hypinfo, evd', res) + let evars, rel' = poly_inverse !hypinfo.sort env evars car rel in + evars, (prf, (car, rel', c2, c1)) + in Some (evd, res) with e when Class_tactics.catchable e -> None -let unfold_impl t = - match kind_of_term t with - | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> - mkProd (Anonymous, a, lift 1 b) - | _ -> assert false - -let unfold_all t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - -let unfold_forall t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - -let arrow_morphism ta tb a b = - let ap = is_Prop ta and bp = is_Prop tb in - if ap && bp then mkApp (Lazy.force impl, [| a; b |]), unfold_impl - else if ap then (* Domain in Prop, CoDomain in Type *) - mkProd (Anonymous, a, b), (fun x -> x) - else if bp then (* Dummy forall *) - mkApp (Lazy.force coq_all, [| a; mkLambda (Anonymous, a, b) |]), unfold_forall - else (* None in Prop, use arrow *) - mkApp (Lazy.force arrow, [| a; b |]), unfold_impl - -let rec decomp_pointwise n c = - if Int.equal n 0 then c - else - match kind_of_term c with - | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) -> - decomp_pointwise (pred n) relb - | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) -> - decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) - | _ -> invalid_arg "decomp_pointwise" - -let rec apply_pointwise rel = function - | arg :: args -> - (match kind_of_term rel with - | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) -> - apply_pointwise relb args - | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) -> - apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args - | _ -> invalid_arg "apply_pointwise") - | [] -> rel - -let pointwise_or_dep_relation n t car rel = - if noccurn 1 car && noccurn 1 rel then - mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |]) - else - mkApp (Lazy.force forall_relation, - [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]) - -let lift_cstr env evars (args : constr list) c ty cstr = - let start evars env car = - match cstr with - | None | Some (_, None) -> - new_cstr_evar evars env (mk_relation car) - | Some (ty, Some rel) -> evars, rel - in - let rec aux evars env prod n = - if Int.equal n 0 then start evars env prod - else - match kind_of_term (Reduction.whd_betadeltaiota env prod) with - | Prod (na, ty, b) -> - if noccurn 1 b then - let b' = lift (-1) b in - let evars, rb = aux evars env b' (pred n) in - evars, mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |]) - else - let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in - evars, mkApp (Lazy.force forall_relation, - [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]) - | _ -> raise Not_found - in - let rec find env c ty = function - | [] -> None - | arg :: args -> - try let evars, found = aux evars env ty (succ (List.length args)) in - Some (evars, found, c, ty, arg :: args) - with Not_found -> - find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args - in find env c ty args - -let unlift_cstr env sigma = function - | None -> None - | Some codom -> Some (decomp_pointwise 1 codom) - type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } let default_flags = { under_lambdas = true; on_morphisms = true; } -type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) - -type rewrite_proof = +type rewrite_proof = | RewPrf of constr * constr | RewCast of cast_kind +let map_rewprf f p = match p with + | RewPrf (x, y) -> RewPrf (f x, f y) + | RewCast _ -> p + let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None type rewrite_result_info = { @@ -523,34 +677,41 @@ type rewrite_result_info = { rew_evars : evars; } -type 'a rewrite_result = -| Fail -| Same -| Info of 'a +type rewrite_result = rewrite_result_info option -type 'a pure_strategy = 'a -> Environ.env -> Id.t list -> constr -> types -> - constr option -> evars -> 'a * rewrite_result_info rewrite_result +type strategy = Environ.env -> Id.t list -> constr -> types -> + (bool (* prop *) * constr option) -> evars -> rewrite_result option -type strategy = unit pure_strategy +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + +let get_rew_rel r = match r.rew_prf with + | RewPrf (rel, prf) -> rel + | RewCast c -> mkApp (make_eq (),[| r.rew_car; r.rew_from; r.rew_to |]) let get_rew_prf r = match r.rew_prf with - | RewPrf (rel, prf) -> rel, prf + | RewPrf (rel, prf) -> rel, prf | RewCast c -> - let rel = mkApp (Coqlib.build_coq_eq (), [| r.rew_car |]) in - rel, mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]), + let rel = mkApp (make_eq (), [| r.rew_car |]) in + rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), c, mkApp (rel, [| r.rew_from; r.rew_to |])) -let resolve_subrelation env avoid car rel prf rel' res = +let poly_subrelation sort = + if sort then PropGlobal.subrelation else TypeGlobal.subrelation + +let resolve_subrelation env avoid car rel sort prf rel' res = if eq_constr rel rel' then res else - let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in - let evars, subrel = new_cstr_evar res.rew_evars env app in + let evars, app = app_poly res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in + let evars, subrel = new_cstr_evar evars env app in let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in { res with rew_prf = RewPrf (rel', appsub); rew_evars = evars } -let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars = +let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = let evars, morph_instance, proj, sigargs, m', args, args' = let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with | Some i -> i @@ -559,21 +720,23 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars let morphargs', morphobjs' = Array.chop first args' in let appm = mkApp(m, morphargs) in let appmtype = Typing.type_of env (goalevars evars) appm in - let cstrs = List.map - (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) - (Array.to_list morphobjs') + let cstrs = List.map + (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) + (Array.to_list morphobjs') in (* Desired signature *) - let evars, appmtype', signature, sigargs = - build_signature evars env appmtype cstrs cstr + let evars, appmtype', signature, sigargs = + if b then PropGlobal.build_signature evars env appmtype cstrs cstr + else TypeGlobal.build_signature evars env appmtype cstrs cstr in (* Actual signature found *) let cl_args = [| appmtype' ; signature ; appm |] in - let app = mkApp (Lazy.force proper_type, cl_args) in + let evars, app = app_poly evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) + cl_args in let env' = Environ.push_named - (Id.of_string "do_subrelation", - Some (Lazy.force do_subrelation), - Lazy.force apply_subrelation) + (Id.of_string "do_subrelation", + Some (snd (app_poly evars PropGlobal.do_subrelation [||])), + snd (app_poly evars PropGlobal.apply_subrelation [||])) env in let evars, morph = new_cstr_evar evars env' app in @@ -589,13 +752,15 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars and relation = substl subst relation in (match y with | None -> - let evars, proof = proper_proof env evars carrier relation x in + let evars, proof = + (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) + env evars carrier relation x in [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' | Some r -> - [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, + [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') | None -> - if not (Option.is_empty y) then + if not (Option.is_empty y) then error "Cannot rewrite the argument of a dependent function"; x :: acc, x :: subst, evars, sigargs, x :: typeargs') ([], [], evars, sigargs, []) args args' @@ -607,66 +772,68 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars | _ -> assert(false) let apply_constraint env avoid car rel prf cstr res = - match cstr with + match snd cstr with | None -> res - | Some r -> resolve_subrelation env avoid car rel prf r res + | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res + +let eq_env x y = x == y -let apply_rule l2r flags by loccs : (hypinfo * int) pure_strategy = +let apply_rule hypinfo by loccs : strategy = let (nowhere_except_in,occs) = convert_occs loccs in let is_occ occ = - if nowhere_except_in - then Int.List.mem occ occs - else not (Int.List.mem occ occs) - in - fun (hypinfo, occ) env avoid t ty cstr evars -> - let unif = unify_eqn l2r flags env evars hypinfo by t in - match unif with - | None -> ((hypinfo, occ), Fail) - | Some (hypinfo, evd', (prf, (car, rel, c1, c2))) -> - let occ = succ occ in - let res = - if not (is_occ occ) then Fail - else if eq_constr t c2 then Same - else - let res = { rew_car = ty; rew_from = c1; - rew_to = c2; rew_prf = RewPrf (rel, prf); - rew_evars = evd', cstrevars evars } - in Info (apply_constraint env avoid car rel prf cstr res) - in - ((hypinfo, occ), res) - -let apply_lemma l2r flags c by loccs : strategy = - fun () env avoid t ty cstr evars -> - let hypinfo = - decompose_applied_relation env (goalevars evars) None c + if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in + let occ = ref 0 in + fun env avoid t ty cstr evars -> + if not (eq_env !hypinfo.cl.env env) then + hypinfo := refresh_hypinfo env (goalevars evars) !hypinfo; + let unif = unify_eqn env evars hypinfo by t in + if not (Option.is_empty unif) then incr occ; + match unif with + | Some (evars', (prf, (car, rel, c1, c2))) when is_occ !occ -> + begin + if eq_constr t c2 then Some None + else + let res = { rew_car = ty; rew_from = c1; + rew_to = c2; rew_prf = RewPrf (rel, prf); + rew_evars = evars' } + in Some (Some (apply_constraint env avoid car rel prf cstr res)) + end + | _ -> None + +let apply_lemma flags (evm,c) left2right by loccs : strategy = + fun env avoid t ty cstr evars -> + let hypinfo = + let evars' = Evd.merge (goalevars evars) evm in + ref (decompose_applied_relation env (goalevars evars) evars' + flags None c left2right) in - let _, res = apply_rule l2r flags by loccs (hypinfo, 0) env avoid t ty cstr evars in - (), res + apply_rule hypinfo by loccs env avoid t ty cstr evars let make_leibniz_proof c ty r = - let prf = + let evars = ref r.rew_evars in + let prf = match r.rew_prf with - | RewPrf (rel, prf) -> - let rel = mkApp (Lazy.force coq_eq, [| ty |]) in + | RewPrf (rel, prf) -> + let rel = e_app_poly evars coq_eq [| ty |] in let prf = - mkApp (Lazy.force coq_f_equal, + e_app_poly evars coq_f_equal [| r.rew_car; ty; mkLambda (Anonymous, r.rew_car, c); - r.rew_from; r.rew_to; prf |]) + r.rew_from; r.rew_to; prf |] in RewPrf (rel, prf) | RewCast k -> r.rew_prf in - { r with rew_car = ty; + { rew_car = ty; rew_evars = !evars; rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf } let reset_env env = let env' = Global.env_of_context (Environ.named_context_val env) in Environ.push_rel_context (Environ.rel_context env) env' - + let fold_match ?(force=false) env sigma c = let (ci, p, c, brs) = destCase c in let cty = Retyping.get_type_of env sigma c in - let dep, pred, exists, (sk, eff) = + let dep, pred, exists, (sk,eff) = let env', ctx, body = let ctx, pred = decompose_lam_assum p in let env' = Environ.push_rel_context ctx env in @@ -678,7 +845,7 @@ let fold_match ?(force=false) env sigma c = let pred = if dep then p else it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) in - let sk = + let sk = if sortp == InProp then if sortc == InProp then if dep then case_dep_scheme_kind_from_prop @@ -691,7 +858,7 @@ let fold_match ?(force=false) env sigma c = if dep then case_dep_scheme_kind_from_type else case_scheme_kind_from_type) - in + in let exists = Ind_tables.check_scheme sk ci.ci_ind in if exists || force then dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind @@ -702,108 +869,121 @@ let fold_match ?(force=false) env sigma c = let pars, args = List.chop ci.ci_npar args in let meths = List.map (fun br -> br) (Array.to_list brs) in applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) - in + in sk, (if exists then env else reset_env env), app, eff let unfold_match env sigma sk app = match kind_of_term app with - | App (f', args) when eq_constr f' (mkConst sk) -> - let v = Environ.constant_value (Global.env ()) sk in + | App (f', args) when eq_constant (fst (destConst f')) sk -> + let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in Reductionops.whd_beta sigma (mkApp (v, args)) | _ -> app let is_rew_cast = function RewCast _ -> true | _ -> false -let coerce env avoid cstr res = +let coerce env avoid cstr res = let rel, prf = get_rew_prf res in apply_constraint env avoid res.rew_car rel prf cstr res -let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = - let rec aux state env avoid t ty cstr evars = +let subterm all flags (s : strategy) : strategy = + let rec aux env avoid t ty (prop, cstr) evars = let cstr' = Option.map (fun c -> (ty, Some c)) cstr in match kind_of_term t with | App (m, args) -> - let rewrite_args state success = - let state, args', evars', progress = + let rewrite_args success = + let args', evars', progress = Array.fold_left - (fun (state, acc, evars, progress) arg -> - if not (Option.is_empty progress) && not all then (state, None :: acc, evars, progress) + (fun (acc, evars, progress) arg -> + if not (Option.is_empty progress) && not all then (None :: acc, evars, progress) else - let state, res = s state env avoid arg (Typing.type_of env (goalevars evars) arg) None evars in + let argty = Typing.type_of env (goalevars evars) arg in + let res = s env avoid arg argty (prop,None) evars in match res with - | Same -> (state, None :: acc, evars, if Option.is_empty progress then Some false else progress) - | Info r -> (state, Some r :: acc, r.rew_evars, Some true) - | Fail -> (state, None :: acc, evars, progress)) - (state, [], evars, success) args + | Some None -> (None :: acc, evars, + if Option.is_empty progress then Some false else progress) + | Some (Some r) -> + (Some r :: acc, r.rew_evars, Some true) + | None -> (None :: acc, evars, progress)) + ([], evars, success) args in - state, match progress with - | None -> Fail - | Some false -> Same + match progress with + | None -> None + | Some false -> Some None | Some true -> let args' = Array.of_list (List.rev args') in if Array.exists - (function - | None -> false + (function + | None -> false | Some r -> not (is_rew_cast r.rew_prf)) args' then - let evars', prf, car, rel, c1, c2 = resolve_morphism env avoid t m args args' cstr' evars' in + let evars', prf, car, rel, c1, c2 = + resolve_morphism env avoid t m args args' (prop, cstr') evars' + in let res = { rew_car = ty; rew_from = c1; rew_to = c2; rew_prf = RewPrf (rel, prf); - rew_evars = evars' } - in Info res - else + rew_evars = evars' } + in Some (Some res) + else let args' = Array.map2 (fun aorig anew -> match anew with None -> aorig - | Some r -> r.rew_to) args args' + | Some r -> r.rew_to) args args' in let res = { rew_car = ty; rew_from = t; rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; rew_evars = evars' } - in Info res + in Some (Some res) in if flags.on_morphisms then let mty = Typing.type_of env (goalevars evars) m in - let evars, cstr', m, mty, argsl, args = + let evars, cstr', m, mty, argsl, args = let argsl = Array.to_list args in - match lift_cstr env evars argsl m mty None with - | Some (evars, cstr', m, mty, args) -> + let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in + match lift env evars argsl m mty None with + | Some (evars, cstr', m, mty, args) -> evars, Some cstr', m, mty, args, Array.of_list args | None -> evars, None, m, mty, argsl, args in - let state, m' = s state env avoid m mty cstr' evars in + let m' = s env avoid m mty (prop, cstr') evars in match m' with - | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) - | Same -> rewrite_args state (Some false) - | Info r -> + | None -> rewrite_args None (* Standard path, try rewrite on arguments *) + | Some None -> rewrite_args (Some false) + | Some (Some r) -> (* We rewrote the function and get a proof of pointwise rel for the arguments. We just apply it. *) let prf = match r.rew_prf with | RewPrf (rel, prf) -> - RewPrf (apply_pointwise rel argsl, mkApp (prf, args)) + let app = if prop then PropGlobal.apply_pointwise + else TypeGlobal.apply_pointwise + in + RewPrf (app rel argsl, mkApp (prf, args)) | x -> x in let res = { rew_car = prod_appvect r.rew_car args; rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); - rew_prf = prf; - rew_evars = r.rew_evars } - in - state, match prf with + rew_prf = prf; rew_evars = r.rew_evars } + in + match prf with | RewPrf (rel, prf) -> - Info (apply_constraint env avoid res.rew_car rel prf cstr res) - | RewCast _ -> Info res - else rewrite_args state None - + Some (Some (apply_constraint env avoid res.rew_car + rel prf (prop,cstr) res)) + | _ -> Some (Some res) + else rewrite_args None + | Prod (n, x, b) when noccurn 1 b -> let b = subst1 mkProp b in - let tx = Typing.type_of env (goalevars evars) x and tb = Typing.type_of env (goalevars evars) b in - let mor, unfold = arrow_morphism tx tb x b in - let state, res = aux state env avoid mor ty cstr evars in - state, (match res with - | Info r -> Info { r with rew_to = unfold r.rew_to } - | Fail | Same -> res) + let tx = Typing.type_of env (goalevars evars) x + and tb = Typing.type_of env (goalevars evars) b in + let arr = if prop then PropGlobal.arrow_morphism + else TypeGlobal.arrow_morphism + in + let (evars', mor), unfold = arr evars tx tb x b in + let res = aux env avoid mor ty (prop,cstr) evars' in + (match res with + | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to }) + | _ -> res) (* if x' = None && flags.under_lambdas then *) (* let lam = mkLambda (n, x, b) in *) @@ -821,80 +1001,116 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Prod (n, dom, codom) -> let lam = mkLambda (n, dom, codom) in - let app, unfold = + let (evars', app), unfold = if eq_constr ty mkProp then - mkApp (Lazy.force coq_all, [| dom; lam |]), unfold_all - else mkApp (Lazy.force coq_forall, [| dom; lam |]), unfold_forall + (app_poly evars coq_all [| dom; lam |]), TypeGlobal.unfold_all + else + let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in + (app_poly evars forall [| dom; lam |]), TypeGlobal.unfold_forall in - let state, res = aux state env avoid app ty cstr evars in - state, (match res with - | Info r -> Info { r with rew_to = unfold r.rew_to } - | Fail | Same -> res) + let res = aux env avoid app ty (prop,cstr) evars' in + (match res with + | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to }) + | _ -> res) + +(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with + H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this. + B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing + dependent relations and using projections to get them out. + *) + (* | Lambda (n, t, b) when flags.under_lambdas -> *) + (* let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *) + (* let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *) + (* let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *) + (* let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *) + (* let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *) + (* let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *) + (* (match b' with *) + (* | Some (Some r) -> *) + (* let prf = match r.rew_prf with *) + (* | RewPrf (rel, prf) -> *) + (* let rel = pointwise_or_dep_relation n' t r.rew_car rel in *) + (* let prf = mkLambda (n', t, prf) in *) + (* RewPrf (rel, prf) *) + (* | x -> x *) + (* in *) + (* Some (Some { r with *) + (* rew_prf = prf; *) + (* rew_car = mkProd (n, t, r.rew_car); *) + (* rew_from = mkLambda(n, t, r.rew_from); *) + (* rew_to = mkLambda (n, t, r.rew_to) }) *) + (* | _ -> b') *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in - let env' = Environ.push_rel (n', None, t) env in - let state, b' = s state env' avoid b (Typing.type_of env' (goalevars evars) b) (unlift_cstr env (goalevars evars) cstr) evars in - state, (match b' with - | Info r -> - let prf = match r.rew_prf with - | RewPrf (rel, prf) -> - let rel = pointwise_or_dep_relation n' t r.rew_car rel in - let prf = mkLambda (n', t, prf) in - RewPrf (rel, prf) - | x -> x + let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in + let env' = Environ.push_rel (n', None, t) env in + let bty = Typing.type_of env' (goalevars evars) b in + let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in + let b' = s env' avoid b bty (prop, unlift env evars cstr) evars in + (match b' with + | Some (Some r) -> + let r = match r.rew_prf with + | RewPrf (rel, prf) -> + let point = if prop then PropGlobal.pointwise_or_dep_relation else + TypeGlobal.pointwise_or_dep_relation in - Info { r with - rew_prf = prf; - rew_car = mkProd (n, t, r.rew_car); - rew_from = mkLambda(n, t, r.rew_from); - rew_to = mkLambda (n, t, r.rew_to) } - | Fail | Same -> b') - + let evars, rel = point r.rew_evars n' t r.rew_car rel in + let prf = mkLambda (n', t, prf) in + { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } + | x -> r + in + Some (Some { r with + rew_car = mkProd (n, t, r.rew_car); + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) }) + | _ -> b') + | Case (ci, p, c, brs) -> - let cty = Typing.type_of env (goalevars evars) c in - let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in - let state, c' = s state env avoid c cty cstr' evars in - let state, res = - match c' with - | Info r -> - let res = make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r in - state, Info (coerce env avoid cstr res) - | Same | Fail -> - if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then - let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in - let state, found, brs' = Array.fold_left - (fun (state, found, acc) br -> - if not (Option.is_empty found) then (state, found, fun x -> lift 1 br :: acc x) - else - let state, res = s state env avoid br ty cstr evars in - match res with - | Info r -> (state, Some r, fun x -> mkRel 1 :: acc x) - | Fail | Same -> (state, None, fun x -> lift 1 br :: acc x)) - (state, None, fun x -> []) brs - in - state, match found with - | Some r -> - let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in - Info (make_leibniz_proof ctxc ty r) - | None -> c' - else - match try Some (fold_match env (goalevars evars) t) with Not_found -> None with - | None -> state, c' - | Some (cst, _, t',_) -> (* eff XXX *) - let state, res = aux state env avoid t' ty cstr evars in - state, match res with - | Info prf -> - Info { prf with - rew_from = t; rew_to = unfold_match env (goalevars evars) cst prf.rew_to } - | x' -> c' - in - state, (match res with - | Info r -> - let rel, prf = get_rew_prf r in - Info (apply_constraint env avoid r.rew_car rel prf cstr r) - | x -> x) - | _ -> state, Fail + let cty = Typing.type_of env (goalevars evars) c in + let evars', eqty = app_poly evars coq_eq [| cty |] in + let cstr' = Some eqty in + let c' = s env avoid c cty (prop, cstr') evars' in + let res = + match c' with + | Some (Some r) -> + let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in + let res = make_leibniz_proof case ty r in + Some (Some (coerce env avoid (prop,cstr) res)) + | x -> + if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then + let evars', eqty = app_poly evars coq_eq [| ty |] in + let cstr = Some eqty in + let found, brs' = Array.fold_left + (fun (found, acc) br -> + if not (Option.is_empty found) then (found, fun x -> lift 1 br :: acc x) + else + match s env avoid br ty (prop,cstr) evars with + | Some (Some r) -> (Some r, fun x -> mkRel 1 :: acc x) + | _ -> (None, fun x -> lift 1 br :: acc x)) + (None, fun x -> []) brs + in + match found with + | Some r -> + let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' x))) in + Some (Some (make_leibniz_proof ctxc ty r)) + | None -> x + else + match try Some (fold_match env (goalevars evars) t) with Not_found -> None with + | None -> x + | Some (cst, _, t', eff (*FIXME*)) -> + match aux env avoid t' ty (prop,cstr) evars with + | Some (Some prf) -> + Some (Some { prf with + rew_from = t; + rew_to = unfold_match env (goalevars evars) cst prf.rew_to }) + | x' -> x + in + (match res with + | Some (Some r) -> + let rel, prf = get_rew_prf r in + Some (Some (apply_constraint env avoid r.rew_car rel prf (prop,cstr) r)) + | x -> x) + | _ -> None in aux let all_subterms = subterm true default_flags @@ -903,25 +1119,35 @@ let one_subterm = subterm false default_flags (** Requires transitivity of the rewrite step, if not a reduction. Not tail-recursive. *) -let transitivity state env avoid (res : rewrite_result_info) (next : 'a pure_strategy) : 'a * rewrite_result_info rewrite_result = - let state, res' = next state env avoid res.rew_to res.rew_car (get_opt_rew_rel res.rew_prf) res.rew_evars in - state, match res' with - | Fail -> Fail - | Same -> Info res - | Info res' -> +let transitivity env avoid prop (res : rewrite_result_info) (next : strategy) : + rewrite_result option = + let nextres = + next env avoid res.rew_to res.rew_car + (prop, get_opt_rew_rel res.rew_prf) res.rew_evars + in + match nextres with + | None -> None + | Some None -> Some (Some res) + | Some (Some res') -> match res.rew_prf with - | RewCast c -> Info { res' with rew_from = res.rew_from } + | RewCast c -> Some (Some { res' with rew_from = res.rew_from }) | RewPrf (rew_rel, rew_prf) -> match res'.rew_prf with - | RewCast _ -> Info { res with rew_to = res'.rew_to } + | RewCast _ -> Some (Some ({ res with rew_to = res'.rew_to })) | RewPrf (res'_rel, res'_prf) -> - let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car; rew_rel |]) in - let evars, prf = new_cstr_evar res'.rew_evars env prfty in - let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; - rew_prf; res'_prf |]) - in Info { res' with rew_from = res.rew_from; - rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } - + let trans = + if prop then PropGlobal.transitive_type + else TypeGlobal.transitive_type + in + let evars, prfty = + app_poly res'.rew_evars trans [| res.rew_car; rew_rel |] + in + let evars, prf = new_cstr_evar evars env prfty in + let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; + rew_prf; res'_prf |]) + in Some (Some { res' with rew_from = res.rew_from; + rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) }) + (** Rewriting strategies. Inspired by ELAN's rewriting strategies: @@ -931,103 +1157,129 @@ let transitivity state env avoid (res : rewrite_result_info) (next : 'a pure_str module Strategies = struct - let fail : 'a pure_strategy = - fun s env avoid t ty cstr evars -> (s, Fail) + let fail : strategy = + fun env avoid t ty cstr evars -> None - let id : 'a pure_strategy = - fun s env avoid t ty cstr evars -> (s, Same) + let id : strategy = + fun env avoid t ty cstr evars -> Some None - let refl : 'a pure_strategy = - fun s env avoid t ty cstr evars -> + let refl : strategy = + fun env avoid t ty (prop,cstr) evars -> let evars, rel = match cstr with - | None -> new_cstr_evar evars env (mk_relation ty) + | None -> + let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in + let evars, rty = mkr evars ty in + new_cstr_evar evars env rty | Some r -> evars, r in let evars, proof = - let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in + let proxy = + if prop then PropGlobal.proper_proxy_type + else TypeGlobal.proper_proxy_type + in + let evars, mty = app_poly evars proxy [| ty ; rel; t |] in new_cstr_evar evars env mty in - s, Info { rew_car = ty; rew_from = t; rew_to = t; - rew_prf = RewPrf (rel, proof); rew_evars = evars } - - let progress (s : 'a pure_strategy) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = s state env avoid t ty cstr evars in - state, match res with - | Fail -> Fail - | Same -> Fail - | Info _ -> res - - let seq (fst : 'a pure_strategy) (snd : 'a pure_strategy) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = fst state env avoid t ty cstr evars in - match res with - | Fail -> state, Fail - | Same -> snd state env avoid t ty cstr evars - | Info res -> transitivity state env avoid res snd - - let choice fst snd : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = fst state env avoid t ty cstr evars in - match res with - | Fail -> snd state env avoid t ty cstr evars - | Same | Info _ -> state, res - - let try_ str : 'a pure_strategy = choice str id - - let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = - let rec aux state env avoid t ty cstr evars = - f aux state env avoid t ty cstr evars - in aux - - let any (s : 'a pure_strategy) : 'a pure_strategy = + Some (Some { rew_car = ty; rew_from = t; rew_to = t; + rew_prf = RewPrf (rel, proof); rew_evars = evars }) + + let progress (s : strategy) : strategy = + fun env avoid t ty cstr evars -> + match s env avoid t ty cstr evars with + | None -> None + | Some None -> None + | r -> r + + let seq first snd : strategy = + fun env avoid t ty cstr evars -> + match first env avoid t ty cstr evars with + | None -> None + | Some None -> snd env avoid t ty cstr evars + | Some (Some res) -> transitivity env avoid (fst cstr) res snd + + let choice fst snd : strategy = + fun env avoid t ty cstr evars -> + match fst env avoid t ty cstr evars with + | None -> snd env avoid t ty cstr evars + | res -> res + + let try_ str : strategy = choice str id + + let fix (f : strategy -> strategy) : strategy = + let rec aux env = f (fun env -> aux env) env in aux + + let any (s : strategy) : strategy = fix (fun any -> try_ (seq s any)) - let repeat (s : 'a pure_strategy) : 'a pure_strategy = + let repeat (s : strategy) : strategy = seq s (any s) - let bu (s : 'a pure_strategy) : 'a pure_strategy = + let bu (s : strategy) : strategy = fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) - let td (s : 'a pure_strategy) : 'a pure_strategy = + let td (s : strategy) : strategy = fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) - let innermost (s : 'a pure_strategy) : 'a pure_strategy = + let innermost (s : strategy) : strategy = fix (fun ins -> choice (one_subterm ins) s) - let outermost (s : 'a pure_strategy) : 'a pure_strategy = + let outermost (s : strategy) : strategy = fix (fun out -> choice s (one_subterm out)) - let lemmas flags cs : 'a pure_strategy = + let lemmas flags cs : strategy = List.fold_left (fun tac (l,l2r,by) -> - choice tac (apply_lemma l2r flags l by AllOccurrences)) + choice tac (apply_lemma flags l l2r by AllOccurrences)) fail cs - let old_hints (db : string) : 'a pure_strategy = + let inj_open hint = + (Evd.from_env ~ctx:hint.Autorewrite.rew_ctx (Global.env()), + (hint.Autorewrite.rew_lemma, NoBindings)) + + let old_hints (db : string) : strategy = let rules = Autorewrite.find_rewrites db in lemmas rewrite_unif_flags - (List.map (fun hint -> ((hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac)) rules) + (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, + hint.Autorewrite.rew_tac)) rules) - let hints (db : string) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> + let hints (db : string) : strategy = + fun env avoid t ty cstr evars -> let rules = Autorewrite.find_matches db t in - let lemma hint = ((hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r, + let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac) in let lems = List.map lemma rules in - lemmas rewrite_unif_flags lems state env avoid t ty cstr evars + lemmas rewrite_unif_flags lems env avoid t ty cstr evars - let reduce (r : Redexpr.red_expr) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let rfn, ckind = Redexpr.reduction_of_red_expr env r in + let reduce (r : Redexpr.red_expr) : strategy = + fun env avoid t ty cstr evars -> + let rfn, ckind = Redexpr.reduction_of_red_expr env r in let t' = rfn env (goalevars evars) t in if eq_constr t' t then - state, Same + Some None else - state, Info { rew_car = ty; rew_from = t; rew_to = t'; - rew_prf = RewCast ckind; rew_evars = evars } + Some (Some { rew_car = ty; rew_from = t; rew_to = t'; + rew_prf = RewCast ckind; rew_evars = evars }) + + let fold c : strategy = + fun env avoid t ty cstr evars -> +(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) + let sigma, c = Constrintern.interp_open_constr (goalevars evars) env c in + let unfolded = + try Tacred.try_red_product env sigma c + with e when Errors.noncritical e -> + error "fold: the term is not unfoldable !" + in + try + let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) + unfolded t in + let c' = Evarutil.nf_evar sigma c in + Some (Some { rew_car = ty; rew_from = t; rew_to = c'; + rew_prf = RewCast DEFAULTcast; + rew_evars = (sigma, snd evars) }) + with e when Errors.noncritical e -> None - let fold_glob c : 'a pure_strategy = - fun state env avoid t ty cstr evars -> + + let fold_glob c : strategy = + fun env avoid t ty cstr evars -> (* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Pretyping.understand_tcc (goalevars evars) env c in let unfolded = @@ -1036,120 +1288,133 @@ module Strategies = error "fold: the term is not unfoldable !" in try - let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in + let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in let c' = Evarutil.nf_evar sigma c in - state, Info { rew_car = ty; rew_from = t; rew_to = c'; + Some (Some { rew_car = ty; rew_from = t; rew_to = c'; rew_prf = RewCast DEFAULTcast; - rew_evars = sigma, cstrevars evars } - with e when Errors.noncritical e -> state, Fail - + rew_evars = (sigma, snd evars) }) + with e when Errors.noncritical e -> None + end (** The strategy for a single rewrite, dealing with occurences. *) -let rewrite_with l2r flags c occs : strategy = - fun () env avoid t ty cstr evars -> +let rewrite_strat flags occs hyp = + let app = apply_rule hyp None occs in + let rec aux () = + Strategies.choice app (subterm true flags (fun env -> aux () env)) + in aux () + +let get_hypinfo_ids {c = opt} = + match opt with + | None -> [] + | Some (is, gc) -> + let avoid = Option.default [] (TacStore.get is.extra f_avoid_ids) in + Id.Map.fold (fun id _ accu -> id :: accu) is.lfun avoid + +let rewrite_with flags c left2right loccs : strategy = + fun env avoid t ty cstr evars -> let gevars = goalevars evars in - let hypinfo = decompose_applied_relation_expr env gevars c in - let (is, _) = c in - let avoid = match TacStore.get is.extra f_avoid_ids with - | None -> avoid - | Some l -> l @ avoid - in - let avoid = Id.Map.fold (fun id _ accu -> id :: accu) is.lfun avoid in - let app = apply_rule l2r flags None occs in - let strat = Strategies.fix (fun aux -> Strategies.choice app (subterm true default_flags aux)) in - let _, res = strat (hypinfo, 0) env avoid t ty cstr (gevars, cstrevars evars) in - ((), res) - -let apply_strategy (s : strategy) env avoid concl cstr evars = - let _, res = - s () env avoid concl (Typing.type_of env (goalevars evars) concl) - (Option.map snd cstr) evars + let hypinfo = ref (decompose_applied_relation_expr env gevars flags c left2right) in + let avoid = get_hypinfo_ids !hypinfo @ avoid in + rewrite_strat default_flags loccs hypinfo env avoid t ty cstr (gevars, cstrevars evars) + +let apply_strategy (s : strategy) env avoid concl (prop, cstr) evars = + let res = + s env avoid concl (Typing.type_of env (goalevars evars) concl) + (prop, Some cstr) evars in match res with - | Fail -> Fail - | Same -> Same - | Info res -> - Info (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to) + | None -> None + | Some None -> Some None + | Some (Some res) -> + Some (Some (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to)) -let solve_constraints env evars = +let solve_constraints env (evars,cstrs) = Typeclasses.resolve_typeclasses env ~split:false ~fail:true evars let nf_zeta = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) -exception RewriteFailure of std_ppcmds +exception RewriteFailure of Pp.std_ppcmds -type result = (evar_map * constr option * types) rewrite_result +type result = (evar_map * constr option * types) option option let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = - let cstr = - let sort = mkProp in - let impl = Lazy.force impl in + let evars = (sigma, Evar.Set.empty) in + let evars, cstr = + let sort = Typing.sort_of env (goalevars evars) concl in + let prop, (evars, arrow) = + if is_prop_sort sort then true, app_poly evars impl [||] + else false, app_poly evars arrow [||] + in match is_hyp with - | None -> (sort, inverse sort impl) - | Some _ -> (sort, impl) + | None -> + let evars, t = poly_inverse prop env evars (mkSort sort) arrow in + evars, (prop, t) + | Some _ -> evars, (prop, arrow) in - let evars = (sigma, Evar.Set.empty) in - let eq = apply_strategy strat env avoid concl (Some cstr) evars in + let eq = apply_strategy strat env avoid concl cstr evars in match eq with - | Fail -> Fail - | Same -> Same - | Info (p, (evars, cstrs), car, oldt, newt) -> - let evars' = solve_constraints env evars in + | Some (Some (p, (evars, cstrs), car, oldt, newt)) -> + let evars' = solve_constraints env (evars, cstrs) in + let p = map_rewprf (fun p -> nf_zeta env evars' (Evarutil.nf_evar evars' p)) p in let newt = Evarutil.nf_evar evars' newt in + let abs = Option.map (fun (x, y) -> + Evarutil.nf_evar evars' x, Evarutil.nf_evar evars' y) abs in let evars = (* Keep only original evars (potentially instantiated) and goal evars, the rest has been defined and substituted already. *) - Evd.fold (fun ev evi acc -> - if Evar.Set.mem ev cstrs then Evd.remove acc ev - else acc) evars' evars' + Evar.Set.fold (fun ev acc -> Evd.remove acc ev) cstrs evars' in - match p with - | RewCast c -> Info (evars, None, newt) - | RewPrf (_, p) -> - let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in - let term = match abs with - | None -> p - | Some (t, ty) -> - let t = Evarutil.nf_evar evars' t in - let ty = Evarutil.nf_evar evars' ty in - mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) - in - let proof = match is_hyp with - | None -> term - | Some id -> mkApp (term, [| mkVar id |]) - in - Info (evars, Some proof, newt) - -(** ppedrot: this is a workaround. The current implementation of rewrite leaks - evar maps. We know that we should not produce effects in here, so we reput - them after computing... *) -let tclEFFECT (tac : tactic) : tactic = fun gl -> - let eff = Evd.eval_side_effects gl.sigma in - let gls = tac gl in - let sigma = Evd.emit_side_effects eff (Evd.drop_side_effects gls.sigma) in - { gls with sigma; } - -let cl_rewrite_clause_tac ?abs strat clause gl = - let evartac evd = Refiner.tclEVARS evd in + let res = + match is_hyp with + | Some id -> + (match p with + | RewPrf (rel, p) -> + let term = + match abs with + | None -> p + | Some (t, ty) -> + mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) + in + Some (evars, Some (mkApp (term, [| mkVar id |])), newt) + | RewCast c -> + Some (evars, None, newt)) + + | None -> + (match p with + | RewPrf (rel, p) -> + (match abs with + | None -> Some (evars, Some p, newt) + | Some (t, ty) -> + let proof = mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) in + Some (evars, Some proof, newt)) + | RewCast c -> Some (evars, None, newt)) + in Some res + | Some None -> Some None + | None -> None + +let rewrite_refine (evd,c) = + Tacmach.refine c + +let cl_rewrite_clause_tac ?abs strat meta clause gl = + let evartac evd = Refiner.tclEVARS (Evd.clear_metas evd) in let treat res = match res with - | Fail -> tclFAIL 0 (str "Nothing to rewrite") - | Same -> - tclFAIL 0 (str"No progress made") - | Info (undef, p, newt) -> - let tac = + | None -> tclFAIL 0 (str "Nothing to rewrite") + | Some None -> tclIDTAC + | Some (Some (undef, p, newt)) -> + let tac = match clause, p with | Some id, Some p -> cut_replacing id newt (Tacmach.refine p) - | Some id, None -> + | Some id, None -> change_in_hyp None newt (id, InHypTypeOnly) | None, Some p -> let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in tclTHENLAST - (Tacmach.internal_cut_no_check false name newt) + (Tacmach.internal_cut false name newt) (tclTHEN (Tactics.revert [name]) (Tacmach.refine p)) | None, None -> change_in_concl None newt in tclTHEN (evartac undef) tac @@ -1162,7 +1427,7 @@ let cl_rewrite_clause_tac ?abs strat clause gl = | None -> pf_concl gl, None in let sigma = project gl in - let concl = Evarutil.nf_evar sigma concl in + let concl = Evarutil.nf_evar sigma concl in let res = cl_rewrite_clause_aux ?abs strat (pf_env gl) [] sigma concl is_hyp in treat res with @@ -1170,35 +1435,35 @@ let cl_rewrite_clause_tac ?abs strat clause gl = Refiner.tclFAIL 0 (str"Unable to satisfy the rewriting constraints." ++ fnl () ++ Himsg.explain_typeclass_error env e) - in tclEFFECT tac gl + in tac gl let bind_gl_info f = - bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) + bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) let new_refine c : Goal.subgoals Goal.sensitive = let refable = Goal.Refinable.make - (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) + (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) in Goal.bind refable Goal.refine -let assert_replacing id newt tac = - let sens = bind_gl_info +let assert_replacing id newt tac = + let sens = bind_gl_info (fun concl env sigma -> - let nc' = + let nc' = Environ.fold_named_context (fun _ (n, b, t as decl) nc' -> if Id.equal n id then (n, b, newt) :: nc' else decl :: nc') env ~init:[] in - let reft = Refinable.make - (fun h -> + let reft = Refinable.make + (fun h -> Goal.bind (Refinable.mkEvar h (Environ.reset_with_named_context (val_of_named_context nc') env) concl) - (fun ev -> + (fun ev -> Goal.bind (Refinable.mkEvar h env newt) (fun ev' -> - let inst = + let inst = fold_named_context (fun _ (n, b, t) inst -> if Id.equal n id then ev' :: inst @@ -1206,34 +1471,32 @@ let assert_replacing id newt tac = env ~init:[] in let (e, args) = destEvar ev in - Goal.return - (mkEvar (e, Array.of_list inst))))) + Goal.return (mkEvar (e, Array.of_list inst))))) in Goal.bind reft Goal.refine) - in Tacticals.New.tclTHEN (Proofview.tclSENSITIVE sens) + in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) (Proofview.tclFOCUS 2 2 tac) -let newfail n s = +let newfail n s = Proofview.tclZERO (Refiner.FailError (n, lazy s)) let cl_rewrite_clause_newtac ?abs strat clause = - let treat (res, is_hyp) = + let treat (res, is_hyp) = match res with - | Fail -> newfail 0 (str "Nothing to rewrite") - | Same -> - newfail 0 (str"No progress made") - | Info res -> + | None -> newfail 0 (str "Nothing to rewrite") + | Some None -> Proofview.tclUNIT () + | Some (Some res) -> match is_hyp, res with | Some id, (undef, Some p, newt) -> assert_replacing id newt (Proofview.tclSENSITIVE (new_refine (undef, p))) - | Some id, (undef, None, newt) -> + | Some id, (undef, None, newt) -> Proofview.tclSENSITIVE (Goal.convert_hyp false (id, None, newt)) | None, (undef, Some p, newt) -> let refable = Goal.Refinable.make - (fun handle -> + (fun handle -> Goal.bind env (fun env -> Goal.bind (Refinable.mkEvar handle env newt) (fun ev -> - Goal.Refinable.constr_of_open_constr handle true + Goal.Refinable.constr_of_open_constr handle true (undef, mkApp (p, [| ev |]))))) in Proofview.tclSENSITIVE (Goal.bind refable Goal.refine) @@ -1248,9 +1511,9 @@ let cl_rewrite_clause_newtac ?abs strat clause = | Some id -> Environ.named_type id env, Some id | None -> concl, None in - try - let res = - cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp + try + let res = + cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp in return (res, is_hyp) with | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> @@ -1262,52 +1525,73 @@ let newtactic_init_setoid () = try init_setoid (); Proofview.tclUNIT () with e when Errors.noncritical e -> Proofview.tclZERO e -let tactic_init_setoid () = +let tactic_init_setoid () = init_setoid (); tclIDTAC - + let cl_rewrite_clause_new_strat ?abs strat clause = - Tacticals.New.tclTHEN (newtactic_init_setoid ()) + Proofview.tclTHEN (newtactic_init_setoid ()) (try cl_rewrite_clause_newtac ?abs strat clause with RewriteFailure s -> newfail 0 (str"setoid rewrite failed: " ++ s)) -let cl_rewrite_clause_newtac' l left2right occs clause = - Proofview.tclFOCUS 1 1 - (cl_rewrite_clause_new_strat (rewrite_with left2right rewrite_unif_flags l occs) clause) +(* let cl_rewrite_clause_newtac' l left2right occs clause = *) +(* Proof_global.run_tactic *) +(* (Proofview.tclFOCUS 1 1 *) +(* (cl_rewrite_clause_new_strat (rewrite_with rewrite_unif_flags l left2right occs) clause)) *) let cl_rewrite_clause_strat strat clause = tclTHEN (tactic_init_setoid ()) - (fun gl -> + (fun gl -> + let meta = Evarutil.new_meta() in (* let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in *) - try cl_rewrite_clause_tac strat clause gl + try cl_rewrite_clause_tac strat (mkMeta meta) clause gl with RewriteFailure e -> tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl - | Refiner.FailError (n, pp) -> + | Refiner.FailError (n, pp) -> tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl) let cl_rewrite_clause l left2right occs clause gl = - cl_rewrite_clause_strat (rewrite_with left2right (general_rewrite_unif_flags ()) l occs) clause gl + cl_rewrite_clause_strat (rewrite_with (general_rewrite_unif_flags ()) l left2right occs) clause gl + +let occurrences_of = function + | n::_ as nl when n < 0 -> (false,List.map abs nl) + | nl -> + if List.exists (fun n -> n < 0) nl then + error "Illegal negative occurrence number."; + (true,nl) + +open Extraargs + +let apply_constr_expr c l2r occs = fun env avoid t ty cstr evars -> + let evd, c = Constrintern.interp_open_constr (goalevars evars) env c in + apply_lemma (general_rewrite_unif_flags ()) (Evd.empty, (c, NoBindings)) + l2r None occs env avoid t ty cstr (evd, cstrevars evars) -let apply_glob_constr c l2r occs = fun () env avoid t ty cstr evars -> +let apply_glob_constr c l2r occs = fun env avoid t ty cstr evars -> let evd, c = (Pretyping.understand_tcc (goalevars evars) env c) in - apply_lemma l2r (general_rewrite_unif_flags ()) (c, NoBindings) - None occs () env avoid t ty cstr (evd, cstrevars evars) + apply_lemma (general_rewrite_unif_flags ()) (Evd.empty, (c, NoBindings)) + l2r None occs env avoid t ty cstr (evd, cstrevars evars) -let interp_glob_constr_list env sigma cl = - let understand sigma (c, _) = - let sigma, c = Pretyping.understand_tcc sigma env c in - (sigma, ((c, NoBindings), true, None)) - in - List.fold_map understand sigma cl +let interp_constr_list env sigma = + List.map (fun c -> + let evd, c = Constrintern.interp_open_constr sigma env c in + (evd, (c, NoBindings)), true, None) + +let interp_glob_constr_list env sigma = + List.map (fun c -> + let evd, c = Pretyping.understand_tcc sigma env c in + (evd, (c, NoBindings)), true, None) -type ('constr,'redexpr) strategy_ast = +(* Syntax for rewriting with strategies *) + +type ('constr,'redexpr) strategy_ast = | StratId | StratFail | StratRefl | StratUnary of string * ('constr,'redexpr) strategy_ast | StratBinary of string * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast | StratConstr of 'constr * bool | StratTerms of 'constr list | StratHints of bool * string - | StratEval of 'redexpr + | StratEval of 'redexpr | StratFold of 'constr let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function @@ -1324,7 +1608,7 @@ let rec strategy_of_ast = function | StratId -> Strategies.id | StratFail -> Strategies.fail | StratRefl -> Strategies.refl - | StratUnary (f, s) -> + | StratUnary (f, s) -> let s' = strategy_of_ast s in let f' = match f with | "subterms" -> all_subterms @@ -1349,28 +1633,31 @@ let rec strategy_of_ast = function in f' s' t' | StratConstr (c, b) -> apply_glob_constr (fst c) b AllOccurrences | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id - | StratTerms l -> - (fun () env avoid t ty cstr (evars, cstrs) -> - let evars, cl = interp_glob_constr_list env evars l in - Strategies.lemmas rewrite_unif_flags cl () env avoid t ty cstr (evars, cstrs)) - | StratEval r -> - (fun () env avoid t ty cstr evars -> + | StratTerms l -> + (fun env avoid t ty cstr evars -> + let l' = interp_glob_constr_list env (goalevars evars) (List.map fst l) in + Strategies.lemmas rewrite_unif_flags l' env avoid t ty cstr evars) + | StratEval r -> + (fun env avoid t ty cstr evars -> let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in - Strategies.reduce r_interp () env avoid t ty cstr (sigma,cstrevars evars)) + Strategies.reduce r_interp env avoid t ty cstr (sigma,cstrevars evars)) | StratFold c -> Strategies.fold_glob (fst c) -let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s))),l) +(* By default the strategy for "rewrite_db" is top-down *) + +let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) let declare_an_instance n s args = ((Loc.ghost,Name n), Explicit, - CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s)), + CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = - new_instance binders instance (Some (CRecord (Loc.ghost,None,fields))) + new_instance (Flags.is_universe_polymorphism ()) + binders instance (Some (CRecord (Loc.ghost,None,fields))) ~global ~generalize:false None let declare_instance_refl global binders a aeq n lemma = @@ -1437,51 +1724,49 @@ let proper_projection r ty = let ctx, inst = decompose_prod_assum ty in let mor, args = destApp inst in let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in - let app = mkApp (Lazy.force proper_proj, + let app = mkApp (Lazy.force PropGlobal.proper_proj, Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx let declare_projection n instance_id r = - let ty = Global.type_of_global r in - let c = constr_of_global r in + let c,uctx = Universes.fresh_global_instance (Global.env()) r in + let poly = Global.is_polymorphic r in + let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in let term = proper_projection c ty in - let env = Global.env() in - let typ = Typing.type_of env Evd.empty term in + let typ = Typing.type_of (Global.env ()) Evd.empty term in let ctx, typ = decompose_prod_assum typ in let typ = let n = let rec aux t = match kind_of_term t with - App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) -> - succ (aux rel') - | _ -> 0 + | App (f, [| a ; a' ; rel; rel' |]) + when Globnames.is_global (PropGlobal.respectful_ref ()) f -> + succ (aux rel') + | _ -> 0 in let init = match kind_of_term typ with - App (f, args) when eq_constr f (Lazy.force respectful) -> + App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f -> mkApp (f, fst (Array.chop (Array.length args - 2) args)) | _ -> typ in aux init in - let ctx,ccl = Reductionops.splay_prod_n env Evd.empty (3 * n) typ + let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in - let cst = - { const_entry_body = Future.from_val (term,Declareops.no_seff); - const_entry_secctx = None; - const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_inline_code = false; - const_entry_feedback = None; - } in - ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) + let cst = + Declare.definition_entry ~types:typ ~poly ~univs:(Univ.ContextSet.to_context uctx) + term + in + ignore(Declare.declare_constant n + (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) let build_morphism_signature m = let env = Global.env () in - let m = Constrintern.interp_constr Evd.empty env m in - let t = Typing.type_of env Evd.empty m in - let evdref = ref (Evd.empty, Evar.Set.empty) in + let m,ctx = Constrintern.interp_constr Evd.empty env m in + let sigma = Evd.from_env ~ctx env in + let t = Typing.type_of env sigma m in let cstrs = let rec aux t = match kind_of_term t with @@ -1490,21 +1775,19 @@ let build_morphism_signature m = | _ -> [] in aux t in - let evars, t', sig_, cstrs = build_signature !evdref env t cstrs None in - let _ = evdref := evars in + let evars, t', sig_, cstrs = + PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t cstrs None in + let evd = ref evars in let _ = List.iter (fun (ty, rel) -> Option.iter (fun rel -> - let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in - let evars,c = new_cstr_evar !evdref env default in - evdref := evars) + let default = e_app_poly evd PropGlobal.default_relation [| ty; rel |] in + ignore(e_new_cstr_evar evd env default)) rel) cstrs in - let morph = - mkApp (Lazy.force proper_type, [| t; sig_; m |]) - in - let evd = solve_constraints env (goalevars !evdref) in + let morph = e_app_poly evd PropGlobal.proper_type [| t; sig_; m |] in + let evd = solve_constraints env !evd in let m = Evarutil.nf_evar evd morph in Evarutil.check_evars env Evd.empty evd m; m @@ -1512,12 +1795,10 @@ let default_morphism sign m = let env = Global.env () in let t = Typing.type_of env Evd.empty m in let evars, _, sign, cstrs = - build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign) + PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign) in - let morph = - mkApp (Lazy.force proper_type, [| t; sign; m |]) - in - let evars, mor = resolve_one_typeclass env (fst evars) morph in + let evars, morph = app_poly evars PropGlobal.proper_type [| t; sign; m |] in + let evars, mor = resolve_one_typeclass env (goalevars evars) morph in mor, proper_projection mor morph let add_setoid global binders a aeq t n = @@ -1532,6 +1813,7 @@ let add_setoid global binders a aeq t n = (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + let make_tactic name = let open Tacexpr in let loc = Loc.ghost in @@ -1541,39 +1823,50 @@ let make_tactic name = let add_morphism_infer glob m n = init_setoid (); + let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = build_morphism_signature m in + let ctx = Univ.ContextSet.empty (*FIXME *) in if Lib.is_modtype () then let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id - (Entries.ParameterEntry (None,instance,None), Decl_kinds.IsAssumption Decl_kinds.Logical) + (Entries.ParameterEntry + (None,poly,(instance,Univ.UContext.empty),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) in - add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst)); + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) None glob + poly (ConstRef cst)); declare_projection n instance_id (ConstRef cst) else - let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in + let kind = Decl_kinds.Global, poly, + Decl_kinds.DefinitionBody Decl_kinds.Instance + in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in + let hook _ = function + | Globnames.ConstRef cst -> + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) None + glob poly (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + | _ -> assert false + in Flags.silently (fun () -> - Lemmas.start_proof instance_id kind instance - (fun _ -> function - Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance (Lazy.force proper_class) None - glob (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false); + Lemmas.start_proof instance_id kind (instance, ctx) hook; ignore (Pfedit.by (Tacinterp.interp tac))) () let add_morphism glob binders m s n = init_setoid (); + let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = ((Loc.ghost,Name instance_id), Explicit, CAppExpl (Loc.ghost, - (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")), + (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - ignore(new_instance ~global:glob binders instance (Some (CRecord (Loc.ghost,None,[]))) + ignore(new_instance ~global:glob poly binders instance (Some (CRecord (Loc.ghost,None,[]))) ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) (** Bind to "rewrite" too *) @@ -1601,22 +1894,24 @@ let check_evar_map_of_evars_defs evd = check_freemetas_is_empty rebus2 freemetas2 ) metas -let unification_rewrite l2r c1 c2 cl car rel but env = +let unification_rewrite flags l2r c1 c2 cl car rel but gl = + let env = pf_env gl in + let evd = Evd.merge (project gl) cl.evd in let (evd',c') = try (* ~flags:(false,true) to allow to mark occurrences that must not be rewritten simply by replacing them with let-defined definitions in the context *) - Unification.w_unify_to_subterm + Unification.w_unify_to_subterm ~flags:{ rewrite_unif_flags with Unification.resolve_evars = true } env - cl.evd ((if l2r then c1 else c2),but) + evd ((if l2r then c1 else c2),but) with Pretype_errors.PretypeError _ -> (* ~flags:(true,true) to make Ring work (since it really exploits conversion) *) - Unification.w_unify_to_subterm - ~flags:{ rewrite2_unif_flags with Unification.resolve_evars = true } - env cl.evd ((if l2r then c1 else c2),but) + Unification.w_unify_to_subterm + ~flags:{ flags with Unification.resolve_evars = true } + env evd ((if l2r then c1 else c2),but) in let cl' = {cl with evd = evd'} in let cl' = Clenvtac.clenv_pose_dependent_evars true cl' in @@ -1626,51 +1921,60 @@ let unification_rewrite l2r c1 c2 cl car rel but env = and car = nf car and rel = nf rel in check_evar_map_of_evars_defs cl'.evd; let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in - let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in - let abs = (prf, prfty) in - abs, {cl=cl'; ext=Evar.Set.empty; prf=(mkRel 1); car=car; rel=rel; - c1=c1; c2=c2; c=None; abs=true; } + let sort = sort_of_rel env evd' (pf_concl gl) in + let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty; + evd = Evd.diff cl'.evd (project gl) } + in + {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; + c1=c1; c2=c2; c=None; abs=Some (prf, prfty); sort = Sorts.is_prop sort; flags = flags} let get_hyp gl evars (c,l) clause l2r = - let env = pf_env gl in - let hi = decompose_applied_relation env evars None (c,l) in + let flags = rewrite2_unif_flags in + let hi = decompose_applied_relation (pf_env gl) evars evars flags None (c,l) l2r in let but = match clause with - | Some id -> pf_get_hyp_typ gl id + | Some id -> pf_get_hyp_typ gl id | None -> Evarutil.nf_evar evars (pf_concl gl) in - unification_rewrite l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but env + let unif = unification_rewrite flags hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl in + { unif with flags = rewrite_unif_flags } let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } +let apply_lemma gl (c,l) cl l2r occs = + let sigma = project gl in + let hypinfo = ref (get_hyp gl sigma (c,l) cl l2r) in + let app = apply_rule hypinfo None occs in + let rec aux () = + Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env)) + in !hypinfo, aux () + + +let cl_rewrite_clause_tac abs strat meta cl gl = + cl_rewrite_clause_tac ~abs strat meta cl gl + +(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *) +(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) + let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = - let app = apply_rule l2r rewrite_unif_flags None occs in - let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in - let substrat = Strategies.fix recstrat in - let abs, hypinfo = get_hyp gl (project gl) (c,l) cl l2r in - let strat () env avoid t ty cstr evars = - let _, res = substrat (hypinfo, 0) env avoid t ty cstr evars in - (), res - in + let meta = Evarutil.new_meta() in + let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in try - (tclWEAK_PROGRESS + tclWEAK_PROGRESS (tclTHEN - (Refiner.tclEVARS hypinfo.cl.evd) - (cl_rewrite_clause_tac ~abs:(Some abs) strat cl))) gl + (Refiner.tclEVARS (Evd.merge (project gl) hypinfo.cl.evd)) + (cl_rewrite_clause_tac hypinfo.abs strat (mkMeta meta) cl)) gl with RewriteFailure e -> - let {c1=x; c2=y} = hypinfo in + let {l2r=l2r; c1=x; c2=y} = hypinfo in raise (Pretype_errors.PretypeError (pf_env gl,project gl, Pretype_errors.NoOccurrenceFound ((if l2r then x else y), cl))) -open Proofview.Notations - let general_s_rewrite_clause x = + init_setoid (); + fun b occs cl ~new_goals -> match x with - | None -> general_s_rewrite None - | Some id -> general_s_rewrite (Some id) -let general_s_rewrite_clause x y z w ~new_goals = - newtactic_init_setoid () <*> - Proofview.V82.tactic (general_s_rewrite_clause x y z w ~new_goals) + | None -> Proofview.V82.tactic (general_s_rewrite None b occs cl ~new_goals) + | Some id -> Proofview.V82.tactic (general_s_rewrite (Some id) b occs cl ~new_goals) let _ = Hook.set Equality.general_rewrite_clause general_s_rewrite_clause @@ -1682,63 +1986,61 @@ let not_declared env ty rel = let setoid_proof ty fn fallback = Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let concl = Proofview.Goal.concl gl in - Proofview.tclORELSE - begin - try - let rel, args = decompose_app_rel env sigma concl in - let evm = sigma in - let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in - fn env evm car rel - with e -> Proofview.tclZERO e - end - begin function - | e -> - Proofview.tclORELSE - fallback - begin function - | Hipattern.NoEquationFound -> - (* spiwack: [Errors.push] here is unlikely to do what - it's intended to, or anything meaningful for that - matter. *) - let e = Errors.push e in - begin match e with - | Not_found -> - let rel, args = decompose_app_rel env sigma concl in - not_declared env ty rel - | _ -> Proofview.tclZERO e - end - | e' -> Proofview.tclZERO e' - end - end + try + let rel, args = decompose_app_rel env sigma concl in + let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env sigma rel)))) in + Proofview.V82.tactic (fn env sigma car rel) + with e when Errors.noncritical e -> + Proofview.tclORELSE fallback (function + | Hipattern.NoEquationFound -> + let e = Errors.push e in + begin match e with + | Not_found -> + let rel, args = decompose_app_rel env sigma concl in + not_declared env ty rel + | _ -> raise e + end + | e -> Proofview.tclZERO e) end +let tac_open ((evm,_), c) tac = + tclTHEN (Refiner.tclEVARS evm) (tac c) + +let poly_proof getp gett env evm car rel = + if Sorts.is_prop (sort_of_rel env evm rel) then + getp env (evm,Evar.Set.empty) car rel + else gett env (evm,Evar.Set.empty) car rel + let setoid_reflexivity = setoid_proof "reflexive" - (fun env evm car rel -> Proofview.V82.tactic (apply (get_reflexive_proof env evm car rel))) + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof + env evm car rel) apply) (reflexivity_red true) let setoid_symmetry = setoid_proof "symmetric" - (fun env evm car rel -> Proofview.V82.tactic (apply (get_symmetric_proof env evm car rel))) + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof + env evm car rel) apply) (symmetry_red true) let setoid_transitivity c = setoid_proof "transitive" (fun env evm car rel -> - Proofview.V82.tactic begin - let proof = get_transitive_proof env evm car rel in - match c with - | None -> eapply proof - | Some c -> apply_with_bindings (proof,ImplicitBindings [ c ]) - end) + let proof = poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof + env evm car rel in + match c with + | None -> tac_open proof eapply + | Some c -> tac_open proof (fun t -> apply_with_bindings (t,ImplicitBindings [ c ]))) (transitivity_red true c) - + let setoid_symmetry_in id = - Proofview.Goal.enter begin fun gl -> - let ctype = Tacmach.New.of_old (fun gl -> pf_type_of gl (mkVar id)) gl in + Proofview.V82.tactic (fun gl -> + let ctype = pf_type_of gl (mkVar id) in let binders,concl = decompose_prod_assum ctype in let (equiv, args) = decompose_app concl in let rec split_last_two = function @@ -1750,12 +2052,81 @@ let setoid_symmetry_in id = let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in let new_hyp' = mkApp (he, [| c2 ; c1 |]) in let new_hyp = it_mkProd_or_LetIn new_hyp' binders in - Tacticals.New.tclTHENS (Tactics.cut new_hyp) - [ Proofview.V82.tactic (intro_replacing id); - Tacticals.New.tclTHENLIST [ intros; setoid_symmetry; Proofview.V82.tactic (apply (mkVar id)); Tactics.assumption ] ] - end + tclTHENS (Proofview.V82.of_tactic (Tactics.cut new_hyp)) + [ intro_replacing id; + tclTHENLIST [ Proofview.V82.of_tactic intros; Proofview.V82.of_tactic setoid_symmetry; apply (mkVar id); Proofview.V82.of_tactic Tactics.assumption ] ] + gl) let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity + +let implify id gl = + let (_, b, ctype) = pf_get_hyp gl id in + let binders,concl = decompose_prod_assum ctype in + let evm, ctype' = + match binders with + | (_, None, ty as hd) :: tl when noccurn 1 concl -> + let env = Environ.push_rel_context tl (pf_env gl) in + let sigma = project gl in + let tyhd = Typing.type_of env sigma ty + and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in + let ((sigma,_), app), unfold = + PropGlobal.arrow_morphism (sigma, Evar.Set.empty) tyhd + (subst1 mkProp tyconcl) ty (subst1 mkProp concl) + in + sigma, it_mkProd_or_LetIn app tl + | _ -> project gl, ctype + in tclTHEN (Refiner.tclEVARS evm) (Tacmach.convert_hyp (id, b, ctype')) gl + +let rec fold_matches env sigma c = + map_constr_with_full_binders Environ.push_rel + (fun env c -> + match kind_of_term c with + | Case _ -> + let cst, env, c', _eff = fold_match ~force:true env sigma c in + fold_matches env sigma c' + | _ -> fold_matches env sigma c) + env c + +let fold_match_tac c gl = + let _, _, c', eff = fold_match ~force:true (pf_env gl) (project gl) c in + let gl = { gl with sigma = Evd.emit_side_effects eff gl.sigma } in + change (Some (snd (Patternops.pattern_of_constr (project gl) c))) c' onConcl gl + +let fold_matches_tac c gl = + let c' = fold_matches (pf_env gl) (project gl) c in + (* let gl = { gl with sigma = Evd.emit_side_effects eff gl.sigma } in *) + change (Some (snd (Patternops.pattern_of_constr (project gl) c))) c' onConcl gl + +let myapply id l gl = + let gr = id in + let _, impls = List.hd (Impargs.implicits_of_global gr) in + let env = pf_env gl in + let evars = ref (project gl) in + let evd, ty = fresh_global env !evars gr in + let _ = evars := evd in + let app = + let rec aux ty impls args args' = + match impls, kind_of_term ty with + | Some (_, _, (_, _)) :: impls, Prod (n, t, t') -> + let arg = Evarutil.e_new_evar evars env t in + aux (subst1 arg t') impls args (arg :: args') + | None :: impls, Prod (n, t, t') -> + (match args with + | [] -> + if dependent (mkRel 1) t' then + let arg = Evarutil.e_new_evar evars env t in + aux (subst1 arg t') impls args (arg :: args') + else + let arg = Evarutil.mk_new_meta () in + evars := meta_declare (destMeta arg) t !evars; + aux (subst1 arg t') impls args (arg :: args') + | arg :: args -> + aux (subst1 arg t') impls args (arg :: args')) + | _, _ -> mkApp (Universes.constr_of_global gr, Array.of_list (List.rev args')) + in aux ty impls l [] + in + tclTHEN (Refiner.tclEVARS !evars) (apply app) gl + diff --git a/tactics/rewrite.mli b/tactics/rewrite.mli index e2d9a41d87..9bdfc08d2e 100644 --- a/tactics/rewrite.mli +++ b/tactics/rewrite.mli @@ -41,10 +41,6 @@ val cl_rewrite_clause : interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> bool -> Locus.occurrences -> Id.t option -> tactic -val cl_rewrite_clause_newtac' : - interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> - bool -> Locus.occurrences -> Id.t option -> unit Proofview.tactic - val is_applied_rewrite_relation : env -> evar_map -> Context.rel_context -> constr -> types option @@ -61,12 +57,6 @@ val add_morphism_infer : bool -> constr_expr -> Id.t -> unit val add_morphism : bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit -val get_reflexive_proof : env -> evar_map -> constr -> constr -> constr - -val get_symmetric_proof : env -> evar_map -> constr -> constr -> constr - -val get_transitive_proof : env -> evar_map -> constr -> constr -> constr - val default_morphism : (types * constr option) option list * (types * types option) option -> constr -> constr * constr diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index 2c1de14ea9..95c6b6bfbf 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -157,7 +157,7 @@ let coerce_to_evaluable_ref env v = else fail () else let ev = match Value.to_constr v with - | Some c when isConst c -> EvalConstRef (destConst c) + | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c)) | Some c when isVar c -> EvalVarRef (destVar c) | _ -> fail () in @@ -213,7 +213,7 @@ let coerce_to_reference env v = let coerce_to_inductive v = match Value.to_constr v with - | Some c when isInd c -> destInd c + | Some c when isInd c -> Univ.out_punivs (destInd c) | _ -> raise (CannotCoerceTo "an inductive type") (* Quantified named or numbered hypothesis or hypothesis in context *) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index cd2319c017..fa76b2a94b 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -138,12 +138,13 @@ let intern_ltac_variable ist = function let intern_constr_reference strict ist = function | Ident (_,id) as r when not strict && find_hyp id ist -> - GVar (dloc,id), Some (CRef r) + GVar (dloc,id), Some (CRef (r,None)) | Ident (_,id) as r when find_ctxvar id ist -> - GVar (dloc,id), if strict then None else Some (CRef r) + GVar (dloc,id), if strict then None else Some (CRef (r,None)) | r -> let loc,_ as lqid = qualid_of_reference r in - GRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r) + GRef (loc,locate_global_with_alias lqid,None), + if strict then None else Some (CRef (r,None)) let intern_move_location ist = function | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id) @@ -278,7 +279,7 @@ let intern_induction_arg ist = function | ElimOnIdent (loc,id) -> if !strict_check then (* If in a defined tactic, no intros-until *) - match intern_constr ist (CRef (Ident (dloc,id))) with + match intern_constr ist (CRef (Ident (dloc,id), None)) with | GVar (loc,id),_ -> ElimOnIdent (loc,id) | c -> ElimOnConstr (c,NoBindings) else diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index ecd7fce314..128d8ea87e 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -295,6 +295,9 @@ let interp_ident = interp_ident_gen false let interp_fresh_ident = interp_ident_gen true let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl) +let interp_global ist gl gr = + Evd.fresh_global (pf_env gl) (project gl) gr + (* Interprets an optional identifier which must be fresh *) let interp_fresh_name ist env = function | Anonymous -> Anonymous @@ -842,7 +845,7 @@ let interp_induction_arg ist gl arg = if Tactics.is_quantified_hypothesis id gl then ElimOnIdent (loc,id) else - let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in + let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in let (sigma,c) = interp_constr ist env sigma c in ElimOnConstr (sigma,(c,NoBindings)) @@ -2104,8 +2107,7 @@ let () = Geninterp.register_interp0 wit_intro_pattern interp; let interp ist gl pat = (project gl, interp_clause ist (pf_env gl) pat) in Geninterp.register_interp0 wit_clause_dft_concl interp; - - let interp ist gl s = (project gl, interp_sort s) in + let interp ist gl s = interp_sort (project gl) s in Geninterp.register_interp0 wit_sort interp let () = @@ -2143,7 +2145,8 @@ let _ = if has_type arg (glbwit wit_tactic) then let tac = out_gen (glbwit wit_tactic) arg in let tac = interp_tactic ist tac in - let prf = Proof.start sigma [env, ty] in + let ctx = Evd.get_universe_context_set sigma in + let prf = Proof.start sigma [env, (ty, ctx)] in let (prf, _) = try Proof.run_tactic env tac prf with Proof_errors.TacticFailure e as src -> diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 997975196a..47fa4f9424 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -74,7 +74,7 @@ open Printer let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in - if not (eq_constr (constr_of_global ref') t') then + if not (eq_constr (Universes.constr_of_global ref') t') then msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ pr_global ref') ; @@ -175,7 +175,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacDecomposeAnd c -> TacDecomposeAnd (subst_glob_constr subst c) | TacDecomposeOr c -> TacDecomposeOr (subst_glob_constr subst c) | TacDecompose (l,c) -> - let l = List.map (subst_or_var (subst_inductive subst)) l in + let l = List.map (subst_or_var (subst_ind subst)) l in TacDecompose (l,subst_glob_constr subst c) | TacSpecialize (n,l) -> TacSpecialize (n,subst_glob_with_bindings subst l) | TacLApply c -> TacLApply (subst_glob_constr subst c) diff --git a/tactics/tacticMatching.ml b/tactics/tacticMatching.ml index b11841a65b..cb54263bbf 100644 --- a/tactics/tacticMatching.ml +++ b/tactics/tacticMatching.ml @@ -232,7 +232,7 @@ module PatternMatching (E:StaticEnvironment) = struct matchings of [term] with the pattern [pat => lhs]. If refresh is true, refreshes the universes of [term]. *) let pattern_match_term refresh pat term lhs = - let term = if refresh then Termops.refresh_universes_strict term else term in +(* let term = if refresh then Termops.refresh_universes_strict term else term in *) match pat with | Term p -> begin diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index bd33e51466..f647ac510d 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -145,7 +145,7 @@ let ifOnHyp pred tac1 tac2 id gl = the elimination. *) type branch_args = { - ity : inductive; (* the type we were eliminating on *) + ity : pinductive; (* the type we were eliminating on *) largs : constr list; (* its arguments *) branchnum : int; (* the branch number *) pred : constr; (* the predicate we used *) @@ -185,7 +185,7 @@ let compute_induction_names n = function | Some (loc,_) -> user_err_loc (loc,"",str "Disjunctive/conjunctive introduction pattern expected.") -let compute_construtor_signatures isrec (_,k as ity) = +let compute_construtor_signatures isrec ((_,k as ity),u) = let rec analrec c recargs = match kind_of_term c, recargs with | Prod (_,_,c), recarg::rest -> @@ -214,10 +214,19 @@ let elimination_sort_of_clause = function | None -> elimination_sort_of_goal | Some id -> elimination_sort_of_hyp id + +let pf_with_evars glsev k gls = + let evd, a = glsev gls in + tclTHEN (Refiner.tclEVARS evd) (k a) gls + +let pf_constr_of_global gr k = + pf_with_evars (fun gls -> pf_apply Evd.fresh_global gls gr) k + (* computing the case/elim combinators *) let gl_make_elim ind gl = - Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) + let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in + pf_apply Evd.fresh_global gl gr let gl_make_case_dep ind gl = pf_apply Indrec.build_case_analysis_scheme gl ind true @@ -535,7 +544,8 @@ module New = struct isrec allnames tac predicate ind (c, t) = Proofview.Goal.enter begin fun gl -> let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in - let elim = Tacmach.New.of_old (mk_elim ind) gl in + (** FIXME: evar leak. *) + let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in (* applying elimination_scheme just a little modified *) let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_type_of gl elim)) gl in let indmv = @@ -550,7 +560,7 @@ module New = struct | _ -> let name_elim = match kind_of_term elim with - | Const kn -> string_of_con kn + | Const (kn, _) -> string_of_con kn | Var id -> string_of_id id | _ -> "\b" in @@ -559,7 +569,7 @@ module New = struct let elimclause' = clenv_fchain indmv elimclause indclause in let branchsigns = compute_construtor_signatures isrec ind in let brnames = compute_induction_names (Array.length branchsigns) allnames in - let flags = Unification.elim_flags in + let flags = Unification.elim_flags () in let elimclause' = match predicate with | None -> elimclause' @@ -591,9 +601,9 @@ module New = struct Proofview.Goal.enter begin fun gl -> let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let isrec,mkelim = - if (Global.lookup_mind (fst ind)).mind_record - then false,gl_make_case_dep - else true,gl_make_elim + match (Global.lookup_mind (fst (fst ind))).mind_record with + | None -> true,gl_make_elim + | Some _ -> false,gl_make_case_dep in general_elim_then_using mkelim isrec None tac None ind (c, t) end @@ -630,4 +640,12 @@ module New = struct | None -> elimination_sort_of_goal gl | Some id -> elimination_sort_of_hyp id gl + let pf_constr_of_global ref tac = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let (sigma, c) = Evd.fresh_global env sigma ref in + Proofview.V82.tclEVARS sigma <*> (tac c) + end + end diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index fcc23df22e..cc15287974 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -101,7 +101,7 @@ val onClauseLR : (Id.t option -> tactic) -> clause -> tactic (** {6 Elimination tacticals. } *) type branch_args = { - ity : inductive; (** the type we were eliminating on *) + ity : pinductive; (** the type we were eliminating on *) largs : constr list; (** its arguments *) branchnum : int; (** the branch number *) pred : constr; (** the predicate we used *) @@ -132,6 +132,9 @@ val elimination_sort_of_goal : goal sigma -> sorts_family val elimination_sort_of_hyp : Id.t -> goal sigma -> sorts_family val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family +val pf_with_evars : (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic +val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic + val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic @@ -237,12 +240,14 @@ module New : sig val case_then_using : intro_pattern_expr located option -> (branch_args -> unit Proofview.tactic) -> - constr option -> inductive -> Term.constr * Term.types -> unit Proofview.tactic + constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic val case_nodep_then_using : intro_pattern_expr located option -> (branch_args -> unit Proofview.tactic) -> - constr option -> inductive -> Term.constr * Term.types -> unit Proofview.tactic + constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic + + val pf_constr_of_global : Globnames.global_reference -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 151c5b2cee..280950600c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -97,7 +97,7 @@ let tactic_infer_flags = { let finish_evar_resolution env initial_sigma (sigma,c) = let sigma = Pretyping.solve_remaining_evars tactic_infer_flags env initial_sigma sigma - in nf_evar sigma c + in Evd.evar_universe_context sigma, nf_evar sigma c (*********************************************) (* Tactics *) @@ -112,7 +112,8 @@ let head_constr_bound t = let _,ccl = decompose_prod_assum t in let hd,args = decompose_app ccl in match kind_of_term hd with - | Const _ | Ind _ | Construct _ | Var _ -> (hd,args) + | Const _ | Ind _ | Construct _ | Var _ -> hd + | Proj (p, _) -> mkConst p | _ -> raise Bound let head_constr c = @@ -128,6 +129,19 @@ let convert_concl = Tacmach.convert_concl let convert_hyp = Tacmach.convert_hyp let thin_body = Tacmach.thin_body +let convert_gen pb x y gl = + try tclEVARS (pf_apply Evd.conversion gl pb x y) gl + with Reduction.NotConvertible -> + tclFAIL_lazy 0 (lazy (str"Not convertible")) + (* Adding more information in this message, even under the lazy, can result in huge *) + (* blowups, time and spacewise... (see autos used in DoubleCyclic.) 2.3s against 15s. *) + (* ++ Printer.pr_constr_env env x ++ *) + (* str" and " ++ Printer.pr_constr_env env y)) *) + gl + +let convert = convert_gen Reduction.CONV +let convert_leq = convert_gen Reduction.CUMUL + let error_clear_dependency env id = function | Evarutil.OccurHypInSimpleClause None -> errorlabstrm "" (pr_id id ++ str " is used in conclusion.") @@ -302,25 +316,54 @@ let reduct_option redfun = function | Some id -> reduct_in_hyp (fst redfun) id | None -> reduct_in_concl (revert_cast redfun) +(** Versions with evars to maintain the unification of universes resulting + from conversions. *) + +let tclWITHEVARS f k gl = + let evm, c' = pf_apply f gl in + tclTHEN (tclEVARS evm) (k c') gl + +let e_reduct_in_concl (redfun,sty) gl = + tclWITHEVARS + (fun env sigma -> redfun env sigma (pf_concl gl)) + (fun c -> convert_concl_no_check c sty) gl + +let e_pf_reduce_decl (redfun : e_reduction_function) where (id,c,ty) env sigma = + match c with + | None -> + if where == InHypValueOnly then + errorlabstrm "" (pr_id id ++ str "has no value."); + let sigma',ty' = redfun env sigma ty in + sigma', (id,None,ty') + | Some b -> + let sigma',b' = if where != InHypTypeOnly then redfun env sigma b else sigma, b in + let sigma',ty' = if where != InHypValueOnly then redfun env sigma ty else sigma', ty in + sigma', (id,Some b',ty') + +let e_reduct_in_hyp redfun (id,where) gl = + tclWITHEVARS + (e_pf_reduce_decl redfun where (pf_get_hyp gl id)) + convert_hyp_no_check gl + (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb t env sigma c = - if is_fconv cv_pb env sigma t c then - t - else - errorlabstrm "convert-check-hyp" (str "Not convertible.") + let evd, b = infer_conv ~pb:cv_pb env sigma t c in + if b then evd, t + else + errorlabstrm "convert-check-hyp" (str "Not convertible.") (* Use cumulativity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb t = function | None -> change_and_check cv_pb t | Some occl -> - contextually false occl + e_contextually false occl (fun subst -> change_and_check Reduction.CONV (replace_vars (Id.Map.bindings subst) t)) let change_in_concl occl t = - reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) + e_reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) let change_in_hyp occl t id = - with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id) + with_check (e_reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id) let change_option occl t = function | Some id -> change_in_hyp occl t id @@ -785,7 +828,7 @@ let index_of_ind_arg t = | None -> error "Could not find inductive argument of elimination scheme." in aux None 0 t -let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indclause gl = +let elimination_clause_scheme with_evars ?(flags=elim_flags ()) i elimclause indclause gl = let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv @@ -830,13 +873,14 @@ let general_elim with_evars c e = let general_case_analysis_in_context with_evars (c,lbindc) gl = let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let sort = elimination_sort_of_goal gl in - let elim = + let sigma, elim = if occur_term c (pf_concl gl) then pf_apply build_case_analysis_scheme gl mind true sort else pf_apply build_case_analysis_scheme_default gl mind sort in - general_elim with_evars (c,lbindc) - {elimindex = None; elimbody = (elim,NoBindings)} gl + tclTHEN (tclEVARS sigma) + (general_elim with_evars (c,lbindc) + {elimindex = None; elimbody = (elim,NoBindings)}) gl let general_case_analysis with_evars (c,lbindc as cx) = match kind_of_term c with @@ -855,17 +899,22 @@ exception IsRecord let is_record mind = (Global.lookup_mind (fst mind)).mind_record +let find_ind_eliminator ind s gl = + let gr = lookup_eliminator ind s in + let evd, c = pf_apply Evd.fresh_global gl gr in + evd, c + let find_eliminator c gl = - let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in - if is_record ind then raise IsRecord; - let c = lookup_eliminator ind (elimination_sort_of_goal gl) in - {elimindex = None; elimbody = (c,NoBindings)} + let ((ind,u),t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + if is_record ind <> None then raise IsRecord; + let evd, c = find_ind_eliminator ind (elimination_sort_of_goal gl) gl in + evd, {elimindex = None; elimbody = (c,NoBindings)} let default_elim with_evars (c,_ as cx) = Proofview.tclORELSE (Proofview.Goal.enter begin fun gl -> - let elim = Tacmach.New.of_old (find_eliminator c) gl in - Proofview.V82.tactic (general_elim with_evars cx elim) + let evd, elim = Tacmach.New.of_old (find_eliminator c) gl in + Proofview.V82.tactic (tclTHEN (tclEVARS evd) (general_elim with_evars cx elim)) end) begin function | IsRecord -> @@ -902,13 +951,13 @@ let simplest_elim c = default_elim false (c,NoBindings) (e.g. it could replace id:A->B->C by id:C, knowing A/\B) *) -let clenv_fchain_in id ?(flags=elim_flags) mv elimclause hypclause = +let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = try clenv_fchain ~flags mv elimclause hypclause with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> (* Set the hypothesis name in the message *) raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) -let elimination_in_clause_scheme with_evars ?(flags=elim_flags) id i elimclause indclause gl = +let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) id i elimclause indclause gl = let indmv = destMeta (nth_arg i elimclause.templval.rebus) in let hypmv = try match List.remove Int.equal indmv (clenv_independent elimclause) with @@ -933,7 +982,7 @@ type conjunction_status = | DefinedRecord of constant option list | NotADefinedRecordUseScheme of constr -let make_projection sigma params cstr sign elim i n c = +let make_projection env sigma params cstr sign elim i n c u = let elim = match elim with | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) @@ -947,24 +996,32 @@ let make_projection sigma params cstr sign elim i n c = && not (isEvar (fst (whd_betaiota_stack sigma t))) then let t = lift (i+1-n) t in - Some (beta_applist (elim,params@[t;branch]),t) + let abselim = beta_applist (elim,params@[t;branch]) in + let c = beta_applist (abselim, [mkApp (c, extended_rel_vect 0 sign)]) in + Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else None | DefinedRecord l -> (* goes from left to right when i increases! *) match List.nth l i with | Some proj -> - let t = Typeops.type_of_constant (Global.env()) proj in let args = extended_rel_vect 0 sign in - Some (beta_applist (mkConst proj,params),prod_applist t (params@[mkApp (c,args)])) + let proj = + if Environ.is_projection proj env then + mkProj (proj, mkApp (c, args)) + else + mkApp (mkConstU (proj,u), Array.append (Array.of_list params) + [|mkApp (c, args)|]) + in + let app = it_mkLambda_or_LetIn proj sign in + let t = Retyping.get_type_of env sigma app in + Some (app, t) | None -> None - in Option.map (fun (abselim,elimt) -> - let c = beta_applist (abselim,[mkApp (c,extended_rel_vect 0 sign)]) in - (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn elimt sign)) elim + in elim let descend_in_conjunctions tac exit c gl = try - let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + let ((ind,u),t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let sign,ccl = decompose_prod_assum t in match match_with_tuple ccl with | Some (_,_,isrec) -> @@ -972,18 +1029,18 @@ let descend_in_conjunctions tac exit c gl = let sort = elimination_sort_of_goal gl in let id = fresh_id [] (Id.of_string "H") gl in let IndType (indf,_) = pf_apply find_rectype gl ccl in - let params = snd (dest_ind_family indf) in + let (_,inst), params = dest_ind_family indf in let cstr = (get_constructors (pf_env gl) indf).(0) in let elim = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> - let elim = pf_apply build_case_analysis_scheme gl ind false sort in - NotADefinedRecordUseScheme elim in + let elim = pf_apply build_case_analysis_scheme gl (ind,u) false sort in + NotADefinedRecordUseScheme (snd elim) in tclFIRST (List.init n (fun i gl -> - match make_projection (project gl) params cstr sign elim i n c with + match pf_apply make_projection gl params cstr sign elim i n c u with | None -> tclFAIL 0 (mt()) gl - | Some (p,pt) -> + | Some (p,pt) -> tclTHENS (internal_cut id pt) [refine p; (* Might be ill-typed due to forbidden elimination. *) @@ -999,7 +1056,7 @@ let descend_in_conjunctions tac exit c gl = let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 = let flags = - if with_delta then default_unify_flags else default_no_delta_unify_flags in + if with_delta then default_unify_flags () else default_no_delta_unify_flags () in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) @@ -1094,7 +1151,7 @@ let apply_in_once_main flags innerclause (d,lbind) gl = let apply_in_once sidecond_first with_delta with_destruct with_evars id (loc,(d,lbind)) gl0 = - let flags = if with_delta then elim_flags else elim_no_delta_flags in + let flags = if with_delta then elim_flags () else elim_no_delta_flags () in let t' = pf_get_hyp_typ gl0 id in let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in let rec aux with_destruct c gl = @@ -1144,13 +1201,17 @@ let cut_and_apply c = (* Exact tactics *) (********************************************************************) +(* let convert_leqkey = Profile.declare_profile "convert_leq";; *) +(* let convert_leq = Profile.profile3 convert_leqkey convert_leq *) + +(* let refine_no_checkkey = Profile.declare_profile "refine_no_check";; *) +(* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) + let exact_check c gl = let concl = (pf_concl gl) in let ct = pf_type_of gl c in - if pf_conv_x_leq gl ct concl then - refine_no_check c gl - else - error "Not an exact proof." + try tclTHEN (convert_leq ct concl) (refine_no_check c) gl + with _ -> error "Not an exact proof." (*FIXME error handling here not the best *) let exact_no_check = refine_no_check let new_exact_no_check c = @@ -1162,8 +1223,8 @@ let vm_cast_no_check c gl = let exact_proof c gl = - let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) - in refine_no_check c gl + let c,ctx = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) + in tclPUSHCONTEXT Evd.univ_flexible ctx (refine_no_check c) gl let assumption = let rec arec gl only_eq = function @@ -1174,12 +1235,12 @@ let assumption = else Tacticals.New.tclZEROMSG (str "No such assumption.") | (id, c, t)::rest -> let concl = Proofview.Goal.concl gl in - let is_same_type = - if only_eq then eq_constr t concl + let sigma = Proofview.Goal.sigma gl in + let (sigma, is_same_type) = + if only_eq then (sigma, eq_constr t concl) else - let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - is_conv_leq env sigma t concl + infer_conv env sigma t concl in if is_same_type then Proofview.Refine.refine (fun h -> (h, mkVar id)) else arec gl only_eq rest @@ -1233,7 +1294,7 @@ let specialize mopt (c,lbind) g = tclEVARS evd, nf_evar evd c else let clause = pf_apply make_clenv_binding g (c,pf_type_of g c) lbind in - let flags = { default_unify_flags with resolve_evars = true } in + let flags = { (default_unify_flags ()) with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in let nargs = List.length tstack in @@ -1299,14 +1360,20 @@ let constructor_tac with_evars expctdnumopt i lbind = let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in - let (mind,redcl) = reduce_to_quantified_ind cl in - let nconstr = - Array.length (snd (Global.lookup_inductive mind)).mind_consnames in - check_number_of_constructors expctdnumopt i nconstr; - let cons = mkConstruct (ith_constructor_of_inductive mind i) in - let apply_tac = Proofview.V82.tactic (general_apply true false with_evars (dloc,(cons,lbind))) in - (Tacticals.New.tclTHENLIST - [Proofview.V82.tactic (convert_concl_no_check redcl DEFAULTcast); intros; apply_tac]) + try (* reduce_to_quantified_ind can raise an exception *) + let (mind,redcl) = reduce_to_quantified_ind cl in + let nconstr = + Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in + check_number_of_constructors expctdnumopt i nconstr; + + let sigma, cons = Evd.fresh_constructor_instance + (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (fst mind, i) in + let cons = mkConstructU cons in + + let apply_tac = Proofview.V82.tactic (general_apply true false with_evars (dloc,(cons,lbind))) in + (Tacticals.New.tclTHENLIST + [Proofview.V82.tactic (tclTHEN (tclEVARS sigma) (convert_concl_no_check redcl DEFAULTcast)); intros; apply_tac]) + with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end let one_constructor i lbind = constructor_tac false None i lbind @@ -1331,7 +1398,7 @@ let any_constructor with_evars tacopt = in let mind = fst (reduce_to_quantified_ind cl) in let nconstr = - Array.length (snd (Global.lookup_inductive mind)).mind_consnames in + Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; tclANY tac (List.interval 1 nconstr) end @@ -1395,7 +1462,7 @@ let intro_decomp_eq loc b l l' thin tac id = let c = mkVar id in let t = Tacmach.New.pf_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in - let eq,eq_args = my_find_eq_data_decompose gl t in + let eq,u,eq_args = my_find_eq_data_decompose gl t in let eq_clause = Tacmach.New.pf_apply make_clenv_binding gl (c,t) NoBindings in !intro_decomp_eq_function (fun n -> tac ((dloc,id)::thin) (adjust_intro_patterns n l @ l')) @@ -1406,7 +1473,7 @@ let intro_or_and_pattern loc b ll l' thin tac id = Proofview.Goal.raw_enter begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_type_of gl c in - let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in + let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in let nv = mis_constr_nargs ind in let bracketed = b || not (List.is_empty l') in let adjust n l = if bracketed then adjust_intro_patterns n l else l in @@ -1660,14 +1727,14 @@ let generalized_name c t ids cl = function constante dont on aurait pu prendre directement le nom *) named_hd (Global.env()) t Anonymous -let generalize_goal gl i ((occs,c,b),na) cl = +let generalize_goal gl i ((occs,c,b),na) (cl,evd) = let t = pf_type_of gl c in let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in - let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in - let cl' = subst_closed_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in + let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in + let cl',evd' = subst_closed_term_univs_occ evd occs c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in - mkProd_or_LetIn (na,b,t) cl' + mkProd_or_LetIn (na,b,t) cl', evd let generalize_dep ?(with_let=false) c gl = let env = pf_env gl in @@ -1697,18 +1764,23 @@ let generalize_dep ?(with_let=false) c gl = | _ -> None else None in - let cl'' = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) cl' in + let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) + (cl',project gl) in let args = instance_from_named_context to_quantify_rev in - tclTHEN - (apply_type cl'' (if Option.is_empty body then c::args else args)) - (thin (List.rev tothin')) + tclTHENLIST + [tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context evd); + apply_type cl'' (if Option.is_empty body then c::args else args); + thin (List.rev tothin')] gl let generalize_gen_let lconstr gl = - let newcl = - List.fold_right_i (generalize_goal gl) 0 lconstr (pf_concl gl) in - apply_type newcl (List.map_filter (fun ((_,c,b),_) -> - if Option.is_empty b then Some c else None) lconstr) gl + let newcl, evd = + List.fold_right_i (generalize_goal gl) 0 lconstr + (pf_concl gl,project gl) + in + tclTHEN (tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context evd)) + (apply_type newcl (List.map_filter (fun ((_,c,b),_) -> + if Option.is_empty b then Some c else None) lconstr)) gl let generalize_gen lconstr = generalize_gen_let (List.map (fun ((occs,c),na) -> @@ -1804,19 +1876,30 @@ let default_matching_flags sigma = { let make_pattern_test env sigma0 (sigma,c) = let flags = default_matching_flags sigma0 in - let matching_fun t = - try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t) + let matching_fun _ t = + try let sigma = w_unify env sigma Reduction.CONV ~flags c t in + Some(sigma, t) with e when Errors.noncritical e -> raise NotUnifiable in let merge_fun c1 c2 = match c1, c2 with - | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) -> - raise NotUnifiable - | _ -> c1 in + | Some (evd,c1), Some (_,c2) -> + (try let evd = w_unify env evd Reduction.CONV ~flags c1 c2 in + Some (evd, c1) + with e when Errors.noncritical e -> raise NotUnifiable) + | Some _, None -> c1 + | None, Some _ -> c2 + | None, None -> None + in { match_fun = matching_fun; merge_fun = merge_fun; testing_state = None; last_found = None }, (fun test -> match test.testing_state with - | None -> finish_evar_resolution env sigma0 (sigma,c) - | Some (sigma,_) -> nf_evar sigma c) + | None -> + let ctx, c = finish_evar_resolution env sigma0 (sigma,c) in + Proofview.V82.tactic (tclPUSHEVARUNIVCONTEXT ctx), c + | Some (sigma,_) -> + let univs, subst = nf_univ_variables sigma in + Proofview.V82.tactic (tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context univs)), + subst_univs_constr subst (nf_evar sigma c)) let letin_abstract id c (test,out) (occs,check_occs) gl = let env = pf_env gl in @@ -1854,13 +1937,13 @@ let letin_tac_gen with_eq name (sigmac,c) test ty occs = if not (mem_named_context x hyps) then x else error ("The variable "^(Id.to_string x)^" is already declared.") in - let (depdecls,lastlhyp,ccl,c) = + let (depdecls,lastlhyp,ccl,(tac,c)) = Tacmach.New.of_old (letin_abstract id c test occs) gl in let t = match ty with Some t -> t | None -> Tacmach.New.pf_apply (fun e s -> typ_of e s c) gl in - let (newcl,eq_tac) = match with_eq with + let (sigma,newcl,eq_tac) = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl @@ -1869,26 +1952,34 @@ let letin_tac_gen with_eq name (sigmac,c) test ty occs = | _ -> Errors.error "Expect an introduction pattern naming one hypothesis." in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in - let eq = applist (eqdata.eq,args) in - let refl = applist (eqdata.refl, [t;mkVar id]) in + let sigma, eq = Evd.fresh_global env (Proofview.Goal.sigma gl) eqdata.eq in + let sigma, refl = Evd.fresh_global env sigma eqdata.refl in + let eq = applist (eq,args) in + let refl = applist (refl, [t;mkVar id]) in + sigma, mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)), Tacticals.New.tclTHEN (intro_gen loc (IntroMustBe heq) lastlhyp true false) (Proofview.V82.tactic (thin_body [heq;id])) | None -> - (mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in + (Proofview.Goal.sigma gl, mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in Tacticals.New.tclTHENLIST - [ Proofview.V82.tactic (convert_concl_no_check newcl DEFAULTcast); + [ Proofview.V82.tclEVARS sigma; tac; Proofview.V82.tactic (convert_concl_no_check newcl DEFAULTcast); intro_gen dloc (IntroMustBe id) lastlhyp true false; Proofview.V82.tactic (tclMAP convert_hyp_no_check depdecls); eq_tac ] end -let make_eq_test c = (make_eq_test c,fun _ -> c) +let make_eq_test evd c = + let out cstr = + let tac = tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context cstr.testing_state) in + Proofview.V82.tactic tac, c + in + (Tacred.make_eq_univs_test Evd.empty c, out) let letin_tac with_eq name c ty occs = Proofview.tclEVARMAP >>= fun sigma -> - letin_tac_gen with_eq name (sigma,c) (make_eq_test c) ty (occs,true) + letin_tac_gen with_eq name (sigma,c) (make_eq_test sigma c) ty (occs,true) let letin_pat_tac with_eq name c ty occs = Proofview.Goal.raw_enter begin fun gl -> @@ -2401,25 +2492,28 @@ let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in error ("Cannot recognize "^s^"an induction scheme.") -let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq -let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl) +let glob = Universes.constr_of_global + +let coq_eq = lazy (glob (Coqlib.build_coq_eq ())) +let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ())) let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") + let mkEq t x y = - mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |]) + mkApp (Lazy.force coq_eq, [| t; x; y |]) let mkRefl t x = - mkApp (Lazy.force coq_eq_refl, [| refresh_universes_strict t; x |]) + mkApp (Lazy.force coq_eq_refl, [| t; x |]) let mkHEq t x u y = mkApp (Lazy.force coq_heq, - [| refresh_universes_strict t; x; refresh_universes_strict u; y |]) + [| t; x; u; y |]) let mkHRefl t x = mkApp (Lazy.force coq_heq_refl, - [| refresh_universes_strict t; x |]) + [| t; x |]) let lift_togethern n l = let l', _ = @@ -2437,8 +2531,8 @@ let ids_of_constr ?(all=false) vars c = | Var id -> Id.Set.add id vars | App (f, args) -> (match kind_of_term f with - | Construct (ind,_) - | Ind ind -> + | Construct ((ind,_),_) + | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in Array.fold_left_from (if all then 0 else mib.Declarations.mind_nparams) @@ -2449,8 +2543,8 @@ let ids_of_constr ?(all=false) vars c = let decompose_indapp f args = match kind_of_term f with - | Construct (ind,_) - | Ind ind -> + | Construct ((ind,_),_) + | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in let first = mib.Declarations.mind_nparams_rec in let pars, args = Array.chop first args in @@ -2552,8 +2646,7 @@ let abstract_args gl generalize_vars dep id defined f args = List.hd rel, c in let argty = pf_type_of gl arg in - let argty = refresh_universes_strict argty in - let ty = refresh_universes_strict ty in + let ty = (* refresh_universes_strict *) ty in let lenctx = List.length ctx in let liftargty = lift lenctx argty in let leq = constr_cmp Reduction.CUMUL liftargty ty in @@ -2656,7 +2749,7 @@ let specialize_eqs id gl = match kind_of_term ty with | Prod (na, t, b) -> (match kind_of_term t with - | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) -> + | App (eq, [| eqty; x; y |]) when eq_constr (Lazy.force coq_eq) eq -> let c = if noccur_between 1 (List.length ctx) x then y else x in let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in @@ -2691,7 +2784,7 @@ let specialize_eqs id gl = let ty' = Evarutil.nf_evar !evars ty' in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') - (exact_no_check (refresh_universes_strict acc')) gl + (exact_no_check ((* refresh_universes_strict *) acc')) gl else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl @@ -2912,7 +3005,7 @@ let compute_scheme_signature scheme names_info ind_type_guess = extra final argument of the form (f x y ...) in the conclusion. In the non standard case, naming of generated hypos is slightly different. *) -let compute_elim_signature ((elimc,elimt),ind_type_guess) names_info = +let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = let scheme = compute_elim_sig ~elimc:elimc elimt in compute_scheme_signature scheme names_info ind_type_guess, scheme @@ -2920,8 +3013,8 @@ let guess_elim isrec hyp0 gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in let s = elimination_sort_of_goal gl in - let elimc = - if isrec && not (is_record mind) then lookup_eliminator mind s + let evd, elimc = + if isrec && not (is_record (fst mind) <> None) then find_ind_eliminator (fst mind) s gl else if use_dependent_propositions_elimination () && dependent_no_evar (mkVar hyp0) (pf_concl gl) @@ -2930,12 +3023,12 @@ let guess_elim isrec hyp0 gl = else pf_apply build_case_analysis_scheme_default gl mind s in let elimt = pf_type_of gl elimc in - ((elimc, NoBindings), elimt), mkInd mind + evd, ((elimc, NoBindings), elimt), mkIndU mind let given_elim hyp0 (elimc,lbind as e) gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in - (e, pf_type_of gl elimc), ind_type_guess + project gl, (e, pf_type_of gl elimc), ind_type_guess let find_elim isrec elim hyp0 gl = match elim with @@ -2950,21 +3043,21 @@ type eliminator_source = | ElimOver of bool * Id.t let find_induction_type isrec elim hyp0 gl = - let scheme,elim = + let evd,scheme,elim = match elim with | None -> - let (elimc,elimt),_ = guess_elim isrec hyp0 gl in + let evd, (elimc,elimt),_ = guess_elim isrec hyp0 gl in let scheme = compute_elim_sig ~elimc elimt in (* We drop the scheme waiting to know if it is dependent *) - scheme, ElimOver (isrec,hyp0) + project gl, scheme, ElimOver (isrec,hyp0) | Some e -> - let (elimc,elimt),ind_guess = given_elim hyp0 e gl in + let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in let scheme = compute_elim_sig ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature scheme hyp0 ind_guess in let elim = ({elimindex = Some(-1); elimbody = elimc},elimt) in - scheme, ElimUsing (elim,indsign) in - Option.get scheme.indref,scheme.nparams, elim + evd, scheme, ElimUsing (elim,indsign) in + evd,(Option.get scheme.indref,scheme.nparams, elim) let find_elim_signature isrec elim hyp0 gl = compute_elim_signature (find_elim isrec elim hyp0 gl) hyp0 @@ -2984,10 +3077,10 @@ let is_functional_induction elim gl = let get_eliminator elim gl = match elim with | ElimUsing (elim,indsign) -> - (* bugged, should be computed *) true, elim, indsign + Proofview.Goal.sigma gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> - let (elimc,elimt),_ as elims = Tacmach.New.of_old (guess_elim isrec id) gl in - isrec, ({elimindex = None; elimbody = elimc}, elimt), + let evd, (elimc,elimt),_ as elims = Tacmach.New.of_old (guess_elim isrec id) gl in + evd, isrec, ({elimindex = None; elimbody = elimc}, elimt), fst (compute_elim_signature elims id) (* Instantiate all meta variables of elimclause using lid, some elts @@ -3041,7 +3134,7 @@ let induction_tac_felim with_evars indvars nparams elim gl = (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv nparams indvars elimclause gl in (* one last resolution (useless?) *) - let resolved = clenv_unique_resolver ~flags:elim_flags elimclause' gl in + let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in clenv_refine with_evars resolved gl (* Apply induction "in place" replacing the hypothesis on which @@ -3049,13 +3142,14 @@ let induction_tac_felim with_evars indvars nparams elim gl = let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names tac = Proofview.Goal.enter begin fun gl -> - let (isrec, elim, indsign) = get_eliminator elim gl in + let (sigma, isrec, elim, indsign) = get_eliminator elim gl in let names = compute_induction_names (Array.length indsign) names in - (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) + Tacticals.New.tclTHEN (Proofview.V82.tclEVARS sigma) + ((if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHEN (induct_tac elim) (Proofview.V82.tactic (tclMAP (fun id -> tclTRY (expand_hyp id)) (List.rev indhyps)))) - (Array.map2 (induct_discharge destopt avoid tac) indsign names) + (Array.map2 (induct_discharge destopt avoid tac) indsign names)) end (* Apply induction "in place" taking into account dependent @@ -3066,7 +3160,7 @@ let apply_induction_in_context hyp0 elim indvars names induct_tac = let env = Proofview.Goal.env gl in let concl = Tacmach.New.pf_nf_concl gl in let statuslists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in - let deps = List.map (on_pi3 refresh_universes_strict) deps in +(* let deps = List.map (on_pi3 refresh_universes_strict) deps in *) let tmpcl = it_mkNamedProd_or_LetIn concl deps in let dephyps = List.map (fun (id,_,_) -> id) deps in let deps_cstr = @@ -3163,11 +3257,11 @@ let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) n let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps = Proofview.Goal.enter begin fun gl -> - let elim_info = Tacmach.New.of_old (find_induction_type isrec elim hyp0) gl in - Tacticals.New.tclTHEN - (atomize_param_of_ind elim_info hyp0) + let sigma, elim_info = Tacmach.New.of_old (find_induction_type isrec elim hyp0) gl in + Tacticals.New.tclTHENLIST + [Proofview.V82.tclEVARS sigma; (atomize_param_of_ind elim_info hyp0); (induction_from_context isrec with_evars elim_info - (hyp0,lbind) names inhyps) + (hyp0,lbind) names inhyps)] end (* Induction on a list of induction arguments. Analyse the elim @@ -3319,9 +3413,10 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) = str "Example: induction x1 x2 x3 using my_scheme."); if not (Option.is_empty cls) then error "'in' clause not supported here."; - let finish_evar_resolution = Tacmach.New.pf_apply finish_evar_resolution gl in - let lc = List.map - (map_induction_arg finish_evar_resolution) lc in + let finish_evar_resolution (sigma, c) = + snd (finish_evar_resolution (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (sigma, c)) + in + let lc = List.map (map_induction_arg finish_evar_resolution) lc in begin match lc with | [_] -> (* Hook to recover standard induction on non-standard induction schemes *) @@ -3398,20 +3493,22 @@ let elim_scheme_type elim t gl = | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) - clenv_unify ~flags:elim_flags Reduction.CUMUL t + clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t (clenv_meta_type clause mv) clause in - res_pf clause' ~flags:elim_flags gl + res_pf clause' ~flags:(elim_flags ()) gl | _ -> anomaly (Pp.str "elim_scheme_type") let elim_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in - let elimc = lookup_eliminator ind (elimination_sort_of_goal gl) in - elim_scheme_type elimc t gl + let evd, elimc = find_ind_eliminator (fst ind) (elimination_sort_of_goal gl) gl in + tclTHEN (tclEVARS evd) (elim_scheme_type elimc t) gl let case_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in - let elimc = pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) in - elim_scheme_type elimc t gl + let evd, elimc = + pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) + in + tclTHEN (tclEVARS evd) (elim_scheme_type elimc t) gl (************************************************) @@ -3492,7 +3589,7 @@ let symmetry_red allowred = Proofview.V82.tactic begin tclTHEN (convert_concl_no_check concl DEFAULTcast) - (apply eq_data.sym) + (pf_constr_of_global eq_data.sym apply) end | None,eq,eq_kind -> prove_symmetry eq eq_kind end @@ -3587,8 +3684,8 @@ let transitivity_red allowred t = tclTHEN (convert_concl_no_check concl DEFAULTcast) (match t with - | None -> eapply eq_data.trans - | Some t -> apply_list [eq_data.trans;t]) + | None -> pf_constr_of_global eq_data.trans eapply + | Some t -> pf_constr_of_global eq_data.trans (fun trans -> apply_list [trans;t])) end | None,eq,eq_kind -> match t with @@ -3613,7 +3710,7 @@ let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) the current goal, abstracted with respect to the local signature, is solved by tac *) -let interpretable_as_section_decl d1 d2 = match d1,d2 with +let interpretable_as_section_decl d1 d2 = match d2,d1 with | (_,Some _,_), (_,None,_) -> false | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 && eq_constr t1 t2 | (_,None,t1), (_,_,t2) -> eq_constr t1 t2 @@ -3639,9 +3736,16 @@ let abstract_subproof id tac = try flush_and_check_evars (Proofview.Goal.sigma gl) concl with Uninstantiated_evar _ -> error "\"abstract\" cannot handle existentials." in + + let evd, ctx, concl = + (* FIXME: should be done only if the tactic succeeds *) + let evd, nf = nf_evars_and_universes (Proofview.Goal.sigma gl) in + let ctx = Evd.get_universe_context_set evd in + evd, ctx, nf concl + in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in - let (const, safe) = - try Pfedit.build_constant_by_tactic id secsign concl solve_tac + let (const, safe, subst) = + try Pfedit.build_constant_by_tactic id secsign (concl, ctx) solve_tac with Proof_errors.TacticFailure e as src -> (* if the tactic [tac] fails, it reports a [TacticFailure e], which is an error irrelevant to the proof system (in fact it @@ -3655,12 +3759,13 @@ let abstract_subproof id tac = let decl = (cd, IsProof Lemma) in (** ppedrot: seems legit to have abstracted subproofs as local*) let cst = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true id decl in - let lem = mkConst cst in + let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in let open Declareops in let eff = Safe_typing.sideff_of_con (Global.safe_env ()) cst in let effs = cons_side_effects eff no_seff in let args = List.rev (instance_from_named_context sign) in - let solve = Proofview.tclEFFECTS effs <*> new_exact_no_check (applist (lem, args)) in + let solve = Proofview.V82.tactic (tclEVARS evd) <*> + Proofview.tclEFFECTS effs <*> new_exact_no_check (applist (lem, args)) in if not safe then Proofview.mark_as_unsafe <*> solve else solve end @@ -3682,12 +3787,53 @@ let admit_as_an_axiom = simplest_case (Coqlib.build_coq_proof_admitted ()) <*> Proofview.mark_as_unsafe +(* let current_sign = Global.named_context() *) +(* and global_sign = pf_hyps gl in *) +(* let poly = Flags.is_universe_polymorphism () in (\*FIXME*\) *) +(* let sign,secsign = *) +(* List.fold_right *) +(* (fun (id,_,_ as d) (s1,s2) -> *) +(* if mem_named_context id current_sign & *) +(* interpretable_as_section_decl (Context.lookup_named id current_sign) d *) +(* then (s1,add_named_decl d s2) *) +(* else (add_named_decl d s1,s2)) *) +(* global_sign (empty_named_context,empty_named_context) in *) +(* let name = add_suffix (get_current_proof_name ()) "_admitted" in *) +(* let na = next_global_ident_away name (pf_ids_of_hyps gl) in *) +(* let evd, nf = nf_evars_and_universes (project gl) in *) +(* let ctx = Evd.universe_context evd in *) +(* let newconcl = nf (pf_concl gl) in *) +(* let newsign = Context.map_named_context nf sign in *) +(* let concl = it_mkNamedProd_or_LetIn newconcl newsign in *) +(* if occur_existential concl then error"\"admit\" cannot handle existentials."; *) +(* let entry = *) +(* (Pfedit.get_used_variables(),poly,(concl,ctx),None) *) +(* in *) +(* let cd = Entries.ParameterEntry entry in *) +(* let decl = (cd, IsAssumption Logical) in *) +(* (\** ppedrot: seems legit to have admitted subproofs as local*\) *) +(* let con = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true na decl in *) +(* let evd, axiom = evd, (mkConstU (con, Univ.UContext.instance ctx)) in *) +(* (\* let evd, axiom = Evd.fresh_global (pf_env gl) (project gl) (ConstRef con) in *\) *) +(* let gl = tclTHEN (tclEVARS evd) *) +(* (tclTHEN (convert_concl_no_check newconcl DEFAULTcast) *) +(* (exact_check *) +(* (applist (axiom, *) +(* List.rev (Array.to_list (instance_from_named_context sign)))))) *) +(* gl *) +(* in *) +(* Pp.feedback Interface.AddedAxiom; *) +(* gl *) +(* >>>>>>> .merge_file_iUuzZK *) + let unify ?(state=full_transparent_state) x y gl = try let flags = - {default_unify_flags with - modulo_delta = state; - modulo_conv_on_closed_terms = Some state} + {(default_unify_flags ()) with + modulo_delta = state; + modulo_delta_types = state; + modulo_delta_in_merge = Some state; + modulo_conv_on_closed_terms = Some state} in let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y in tclEVARS evd gl diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 9a2af08351..937efdae12 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -26,8 +26,8 @@ open Locus (** {6 General functions. } *) -val head_constr : constr -> constr * constr list -val head_constr_bound : constr -> constr * constr list +val head_constr : constr -> constr +val head_constr_bound : constr -> constr val is_quantified_hypothesis : Id.t -> goal sigma -> bool exception Bound @@ -45,6 +45,9 @@ val fix : Id.t option -> int -> tactic val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> tactic val cofix : Id.t option -> tactic +val convert : constr -> constr -> tactic +val convert_leq : constr -> constr -> tactic + (** {6 Introduction tactics. } *) val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 2a35e32d97..8d3d335102 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -97,16 +97,16 @@ let is_unit_or_eq flags ist = let is_record t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind (ind,u) -> let (mib,mip) = Global.lookup_inductive ind in - mib.Declarations.mind_record + mib.Declarations.mind_record <> None | _ -> false let bugged_is_binary t = isApp t && let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind (ind,u) -> let (mib,mip) = Global.lookup_inductive ind in Int.equal mib.Declarations.mind_nparams 2 | _ -> false @@ -319,7 +319,7 @@ let tauto_gen flags = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> try - let nnpp = constr_of_global (Nametab.global_of_path coq_nnpp_path) in + let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in (* try intuitionistic version first to avoid an axiom if possible *) Tacticals.New.tclORELSE (tauto_intuitionistic flags) (tauto_classical flags nnpp) with Not_found -> diff --git a/tactics/termdn.ml b/tactics/termdn.ml new file mode 100644 index 0000000000..1c4c4b6483 --- /dev/null +++ b/tactics/termdn.ml @@ -0,0 +1,136 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Term +open Pattern +open Patternops +open Globnames + +(* Discrimination nets of terms. + See the module dn.ml for further explanations. + Eduardo (5/8/97) *) +module Make = + functor (Z : Map.OrderedType) -> +struct + + module X = struct + type t = constr_pattern + let compare = Pervasives.compare (** FIXME *) + end + + type term_label = + | GRLabel of global_reference + | ProdLabel + | LambdaLabel + | SortLabel + + module Y = struct + type t = term_label + let compare x y = + let make_name n = + match n with + | GRLabel(ConstRef con) -> + GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | GRLabel(IndRef (kn,i)) -> + GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | GRLabel(ConstructRef ((kn,i),j ))-> + GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + + module Dn = Dn.Make(X)(Y)(Z) + + type t = Dn.t + + type 'a lookup_res = 'a Dn.lookup_res + +(*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*) + +let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Cast (c1,_,_) -> decrec acc c1 + | Proj (p, c) -> decrec (c :: acc) (mkConst p) + | _ -> (c,acc) + in + decrec [] + +let decomp_pat = + let rec decrec acc = function + | PApp (f,args) -> decrec (Array.to_list args @ acc) f + | c -> (c,acc) + in + decrec [] + +let constr_pat_discr t = + if not (occur_meta_pattern t) then + None + else + match decomp_pat t with + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) + | _ -> None + +let constr_pat_discr_st (idpred,cpred) t = + match decomp_pat t with + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) -> + Some(GRLabel ref,args) + | PVar v, args when not (Id.Pred.mem v idpred) -> + Some(GRLabel (VarRef v),args) + | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) -> + Some (GRLabel ref, args) + | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) + | PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l) + | PSort s, [] -> Some (SortLabel, []) + | _ -> None + +open Dn + +let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) + | Var id -> Label(GRLabel (VarRef id),l) + | Const _ -> Everything + | Proj _ -> Everything + | _ -> Nothing + +let constr_val_discr_st (idpred,cpred) t = + let c, l = decomp t in + match kind_of_term c with + | Const (c,_) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) + | Ind (ind_sp,_) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,_) -> Label(GRLabel (ConstructRef cstr_sp),l) + | Proj (p,c) -> if Cpred.mem p cpred then Everything else Label(GRLabel (ConstRef p),c::l) + | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) + | Prod (n, d, c) -> Label(ProdLabel, [d; c]) + | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l) + | Sort _ -> Label (SortLabel, []) + | Evar _ -> Everything + | _ -> Nothing + +let create = Dn.create + +let add dn st = Dn.add dn (constr_pat_discr_st st) + +let rmv dn st = Dn.rmv dn (constr_pat_discr_st st) + +let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t + +let app f dn = Dn.app f dn + +end |