From 97fefe1fcca363a1317e066e7f4b99b9c1e9987b Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 12 Jan 2012 16:02:20 +0100 Subject: Imported Upstream version 8.4~beta --- tactics/auto.ml | 694 +++++++++++++------ tactics/auto.mli | 170 +++-- tactics/autorewrite.ml | 22 +- tactics/autorewrite.mli | 14 +- tactics/btermdn.ml | 4 +- tactics/btermdn.mli | 8 +- tactics/class_tactics.ml4 | 810 +++++++++++----------- tactics/contradiction.ml | 6 +- tactics/contradiction.mli | 8 +- tactics/decl_interp.ml | 472 ------------- tactics/decl_interp.mli | 18 - tactics/decl_proof_instr.ml | 1518 ------------------------------------------ tactics/decl_proof_instr.mli | 119 ---- tactics/dhyp.ml | 10 +- tactics/dhyp.mli | 10 +- tactics/dn.mli | 5 +- tactics/eauto.ml4 | 123 ++-- tactics/eauto.mli | 13 +- tactics/elim.ml | 12 +- tactics/elim.mli | 12 +- tactics/elimschemes.ml | 4 +- tactics/elimschemes.mli | 8 +- tactics/eqdecide.ml4 | 11 +- tactics/eqschemes.ml | 35 +- tactics/eqschemes.mli | 13 +- tactics/equality.ml | 286 +++++--- tactics/equality.mli | 24 +- tactics/evar_tactics.ml | 9 +- tactics/evar_tactics.mli | 10 +- tactics/extraargs.ml4 | 56 +- tactics/extraargs.mli | 36 +- tactics/extratactics.ml4 | 158 ++++- tactics/extratactics.mli | 4 +- tactics/hiddentac.ml | 25 +- tactics/hiddentac.mli | 35 +- tactics/hipattern.ml4 | 13 +- tactics/hipattern.mli | 53 +- tactics/inv.ml | 10 +- tactics/inv.mli | 8 +- tactics/leminv.ml | 78 +-- tactics/leminv.mli | 4 +- tactics/nbtermdn.ml | 4 +- tactics/nbtermdn.mli | 8 +- tactics/refine.ml | 10 +- tactics/refine.mli | 4 +- tactics/rewrite.ml4 | 1143 +++++++++++++++++++------------ tactics/tacinterp.ml | 530 +++++++-------- tactics/tacinterp.mli | 71 +- tactics/tactic_option.ml | 6 +- tactics/tactic_option.mli | 4 +- tactics/tacticals.ml | 17 +- tactics/tacticals.mli | 61 +- tactics/tactics.ml | 787 +++++++++++----------- tactics/tactics.mli | 111 +-- tactics/tactics.mllib | 2 - tactics/tauto.ml4 | 13 +- tactics/termdn.ml | 6 +- tactics/termdn.mli | 22 +- 58 files changed, 3118 insertions(+), 4609 deletions(-) delete mode 100644 tactics/decl_interp.ml delete mode 100644 tactics/decl_interp.mli delete mode 100644 tactics/decl_proof_instr.ml delete mode 100644 tactics/decl_proof_instr.mli (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 6a9ced3e..93ca89f4 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* search_entry - Le constr correspond à la constante de tête de la conclusion. + Le constr correspond à la constante de tête de la conclusion. Une search_entry est un triplet comprenant : - - la liste des tactiques qui n'ont pas de pattern associé + - la liste des tactiques qui n'ont pas de pattern associé - la liste des tactiques qui ont un pattern - - un discrimination net borné (Btermdn.t) constitué de tous les + - un discrimination net borné (Btermdn.t) constitué de tous les patterns de la seconde liste de tactiques *) -type stored_data = pri_auto_tactic +type stored_data = int * pri_auto_tactic + (* First component is the index of insertion in the table, to keep most recent first semantics. *) + +let auto_tactic_ord code1 code2 = + match code1, code2 with + | Res_pf (c1, _), Res_pf (c2, _) + | ERes_pf (c1, _), ERes_pf (c2, _) + | Give_exact c1, Give_exact c2 + | Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> constr_ord c1 c2 + | Unfold_nth (EvalVarRef i1), Unfold_nth (EvalVarRef i2) -> Pervasives.compare i1 i2 + | Unfold_nth (EvalConstRef c1), Unfold_nth (EvalConstRef c2) -> + kn_ord (canonical_con c1) (canonical_con c2) + | Extern t1, Extern t2 -> Pervasives.compare t1 t2 + | _ -> Pervasives.compare code1 code2 module Bounded_net = Btermdn.Make(struct type t = stored_data - let compare = Pervasives.compare + let compare = pri_order_int end) type search_entry = stored_data list * stored_data list * Bounded_net.t let empty_se = ([],[],Bounded_net.create ()) -let eq_pri_auto_tactic x y = +let eq_pri_auto_tactic (_, x) (_, y) = if x.pri = y.pri && x.pat = y.pat then match x.code,y.code with | Res_pf(cstr,_),Res_pf(cstr1,_) -> @@ -118,15 +149,18 @@ let eq_pri_auto_tactic x y = let add_tac pat t st (l,l',dn) = match pat with | None -> if not (List.exists (eq_pri_auto_tactic t) l) then (insert t l, l', dn) else (l, l', dn) - | Some pat -> if not (List.exists (eq_pri_auto_tactic t) l') then (l, insert t l', Bounded_net.add st dn (pat,t)) else (l, l', dn) + | Some pat -> + if not (List.exists (eq_pri_auto_tactic t) l') + then (l, insert t l', Bounded_net.add st dn (pat,t)) else (l, l', dn) -let rebuild_dn st (l,l',dn) = - (l, l', List.fold_left (fun dn t -> Bounded_net.add (Some st) dn (Option.get t.pat, t)) +let rebuild_dn st ((l,l',dn) : search_entry) = + (l, l', List.fold_left (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t))) (Bounded_net.create ()) l') + let lookup_tacs (hdc,c) st (l,l',dn) = let l' = List.map snd (Bounded_net.lookup st dn c) in - let sl' = Sort.list pri_order l' in + let sl' = List.stable_sort pri_order_int l' in Sort.merge pri_order l sl' module Constr_map = Map.Make(RefOrdered) @@ -136,11 +170,138 @@ let is_transparent_gr (ids, csts) = function | ConstRef cst -> Cpred.mem cst csts | IndRef _ | ConstructRef _ -> false +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 } + 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 + | Unfold_nth e -> Unfold_nth e + | Extern t -> Extern t + in + (go,{ p with code = code }) + +let path_matches hp hints = + let rec aux hp hints k = + match hp, hints with + | PathAtom _, [] -> false + | PathAtom PathAny, (_ :: hints') -> k hints' + | PathAtom p, (h :: hints') -> + if p = h then k hints' else false + | PathStar hp', hints -> + k hints || aux hp' hints (fun hints' -> aux hp hints' k) + | PathSeq (hp, hp'), hints -> + aux hp hints (fun hints' -> aux hp' hints' k) + | PathOr (hp, hp'), hints -> + aux hp hints k || aux hp' hints k + | PathEmpty, _ -> false + | PathEpsilon, hints -> k hints + in aux hp hints (fun hints' -> true) + +let rec matches_epsilon = function + | PathAtom _ -> false + | PathStar _ -> true + | PathSeq (p, p') -> matches_epsilon p && matches_epsilon p' + | PathOr (p, p') -> matches_epsilon p || matches_epsilon p' + | PathEmpty -> false + | PathEpsilon -> true + +let rec is_empty = function + | PathAtom _ -> false + | PathStar _ -> false + | PathSeq (p, p') -> is_empty p || is_empty p' + | PathOr (p, p') -> matches_epsilon p && matches_epsilon p' + | PathEmpty -> true + | PathEpsilon -> false + +let rec path_derivate hp hint = + let rec derivate_atoms hints hints' = + match hints, hints' with + | gr :: grs, gr' :: grs' when gr = gr' -> derivate_atoms grs grs' + | [], [] -> PathEpsilon + | [], hints -> PathEmpty + | grs, [] -> PathAtom (PathHints grs) + | _, _ -> PathEmpty + in + match hp with + | PathAtom PathAny -> PathEpsilon + | PathAtom (PathHints grs) -> + (match grs, hint with + | h :: hints, PathAny -> PathEmpty + | hints, PathHints hints' -> derivate_atoms hints hints' + | _, _ -> assert false) + | PathStar p -> if path_matches p [hint] then hp else PathEpsilon + | PathSeq (hp, hp') -> + let hpder = path_derivate hp hint in + if matches_epsilon hp then + PathOr (PathSeq (hpder, hp'), path_derivate hp' hint) + else if is_empty hpder then PathEmpty + else PathSeq (hpder, hp') + | PathOr (hp, hp') -> + PathOr (path_derivate hp hint, path_derivate hp' hint) + | PathEmpty -> PathEmpty + | PathEpsilon -> PathEmpty + +let rec normalize_path h = + match h with + | PathStar PathEpsilon -> PathEpsilon + | PathSeq (PathEmpty, _) | PathSeq (_, PathEmpty) -> PathEmpty + | PathSeq (PathEpsilon, p) | PathSeq (p, PathEpsilon) -> normalize_path p + | PathOr (PathEmpty, p) | PathOr (p, PathEmpty) -> normalize_path p + | PathOr (p, q) -> + let p', q' = normalize_path p, normalize_path q in + if p = p' && q = q' then h + else normalize_path (PathOr (p', q')) + | PathSeq (p, q) -> + let p', q' = normalize_path p, normalize_path q in + if p = p' && q = q' then h + else normalize_path (PathSeq (p', q')) + | _ -> h + +let path_derivate hp hint = normalize_path (path_derivate hp hint) + +let rec pp_hints_path = function + | PathAtom (PathAny) -> str"." + | PathAtom (PathHints grs) -> prlist_with_sep pr_spc pr_global grs + | PathStar p -> str "(" ++ pp_hints_path p ++ str")*" + | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p' + | PathOr (p, p') -> + str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")" + | PathEmpty -> str"Ø" + | PathEpsilon -> str"ε" + +let rec subst_hints_path subst hp = + match hp with + | PathAtom PathAny -> hp + | PathAtom (PathHints grs) -> + let gr' gr = fst (subst_global subst gr) in + let grs' = list_smartmap gr' grs in + if grs' == grs then hp else PathAtom (PathHints grs') + | PathStar p -> let p' = subst_hints_path subst p in + if p' == p then hp else PathStar p' + | PathSeq (p, q) -> + let p' = subst_hints_path subst p in + let q' = subst_hints_path subst q in + if p' == p && q' == q then hp else PathSeq (p', q') + | PathOr (p, q) -> + let p' = subst_hints_path subst p in + let q' = subst_hints_path subst q in + if p' == p && q' == q then hp else PathOr (p', q') + | _ -> hp + module Hint_db = struct type t = { hintdb_state : Names.transparent_state; + hintdb_cut : hints_path; hintdb_unfolds : Idset.t * Cset.t; + mutable hintdb_max_id : int; use_dn : bool; hintdb_map : search_entry Constr_map.t; (* A list of unindexed entries starting with an unfoldable constant @@ -148,8 +309,13 @@ module Hint_db = struct hintdb_nopat : (global_reference option * stored_data) list } + let next_hint_id t = + let h = t.hintdb_max_id in t.hintdb_max_id <- succ t.hintdb_max_id; h + let empty st use_dn = { hintdb_state = st; + hintdb_cut = PathEmpty; hintdb_unfolds = (Idset.empty, Cset.empty); + hintdb_max_id = 0; use_dn = use_dn; hintdb_map = Constr_map.empty; hintdb_nopat = [] } @@ -157,47 +323,54 @@ module Hint_db = struct let find key db = try Constr_map.find key db.hintdb_map with Not_found -> empty_se - + let map_none db = - Sort.merge pri_order (List.map snd db.hintdb_nopat) [] - + List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) []) + let map_all k db = let (l,l',_) = find k db in - Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l' + List.map snd (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 - Sort.merge pri_order (List.map snd db.hintdb_nopat) l' + List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) l') let is_exact = function | Give_exact _ -> true | _ -> false - let addkv gr v db = + let is_unfold = function + | Unfold_nth _ -> true + | _ -> false + + let addkv gr id v db = + let idv = id, v in let k = match gr with - | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr then None else Some gr + | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr && + is_unfold v.code then None else Some gr | None -> None in let dnst = if db.use_dn then Some db.hintdb_state else None in let pat = if not db.use_dn && is_exact v.code then None else v.pat in match k with | None -> - if not (List.exists (fun (_, v') -> v = v') db.hintdb_nopat) then - { db with hintdb_nopat = (gr,v) :: db.hintdb_nopat } + if not (List.exists (fun (_, (_, v')) -> v = v') db.hintdb_nopat) then + { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } else db | Some gr -> let oval = find gr db in - { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map } + { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map } let rebuild_db st' db = let db' = { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map; hintdb_state = st'; hintdb_nopat = [] } in - List.fold_left (fun db (gr,v) -> addkv gr v db) db' db.hintdb_nopat + List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat - let add_one (k,v) db = + let add_one kv db = + let (k,v) = translate_hint kv in let st',db,rebuild = match v.code with | Unfold_nth egr -> @@ -211,13 +384,27 @@ module Hint_db = struct | _ -> db.hintdb_state, db, false in let db = if db.use_dn && rebuild then rebuild_db st' db else db - in addkv k v db + in addkv k (next_hint_id db) v db let add_list l db = List.fold_right add_one l db + let remove_sdl p sdl = list_smartfilter p sdl + let remove_he st p (sl1, sl2, dn as he) = + let sl1' = remove_sdl p sl1 and sl2' = remove_sdl p sl2 in + if sl1' == sl1 && sl2' == sl2 then he + else rebuild_dn st (sl1', sl2', dn) + + let remove_list grs db = + let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem gr grs) | _ -> true in + let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in + let hintnopat = list_smartfilter (fun (ge, sd) -> filter sd) db.hintdb_nopat in + { db with hintdb_map = hintmap; hintdb_nopat = hintnopat } + + let remove_one gr db = remove_list [gr] db + let iter f db = - f None (List.map snd db.hintdb_nopat); - Constr_map.iter (fun k (l,l',_) -> f (Some k) (l@l')) db.hintdb_map + 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 let transparent_state db = db.hintdb_state @@ -225,6 +412,11 @@ module Hint_db = struct if db.use_dn then rebuild_db st db else { db with hintdb_state = st } + let add_cut path db = + { db with hintdb_cut = normalize_path (PathOr (db.hintdb_cut, path)) } + + let cut db = db.hintdb_cut + let unfolds db = db.hintdb_unfolds let use_dn db = db.use_dn @@ -255,6 +447,9 @@ let current_db_names () = (**************************************************************************) let auto_init : (unit -> unit) ref = ref (fun () -> ()) +let add_auto_init f = + let init = !auto_init in + auto_init := (fun () -> init (); f ()) let init () = searchtable := Hintdbmap.empty; !auto_init () let freeze () = !searchtable @@ -280,47 +475,51 @@ let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable." -let dummy_goal = - {it = make_evar empty_named_context_val mkProp; - sigma = empty} +let name_of_constr c = try Some (global_of_constr c) with Not_found -> None -let make_exact_entry sigma pri (c,cty) = +let make_exact_entry sigma pri ?(name=PathAny) (c,cty) = let cty = strip_outer_cast cty in match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" | _ -> let pat = snd (Pattern.pattern_of_constr sigma cty) in - let head = - try head_of_constr_reference (fst (head_constr cty)) - with _ -> failwith "make_exact_entry" + let hd = + try head_pattern_bound pat + with BoundPattern -> failwith "make_exact_entry" in - (Some head, - { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c }) + (Some hd, + { pri = (match pri with None -> 0 | Some p -> p); + pat = Some pat; + name = name; + code = Give_exact c }) -let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) = +let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) = 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 c' = clenv_type (* ~reduce:false *) ce in let pat = snd (Pattern.pattern_of_constr sigma c') in - let hd = (try head_pattern_bound pat - with BoundPattern -> failwith "make_apply_entry") in + let hd = + try head_pattern_bound pat + with BoundPattern -> failwith "make_apply_entry" in let nmiss = List.length (clenv_missing ce) in if nmiss = 0 then (Some hd, { pri = (match pri with None -> nb_hyp cty | Some p -> p); pat = Some pat; - code = Res_pf(c,{ce with env=empty_env}) }) + name = name; + code = Res_pf(c,cty) }) else begin if not eapply then failwith "make_apply_entry"; if verbose then warn (str "the hint: eapply " ++ pr_lconstr c ++ str " will only be used by eauto"); (Some hd, - { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); - pat = Some pat; - code = ERes_pf(c,{ce with env=empty_env}) }) + { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); + pat = Some pat; + name = name; + code = ERes_pf(c,cty) }) end | _ -> failwith "make_apply_entry" @@ -328,12 +527,12 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) = c is a constr cty is the type of constr *) -let make_resolves env sigma flags pri c = - let cty = type_of env sigma c in +let make_resolves env sigma flags pri ?name c = + let cty = Retyping.get_type_of env sigma c in let ents = map_succeed (fun f -> f (c,cty)) - [make_exact_entry sigma pri; make_apply_entry env sigma flags pri] + [make_exact_entry sigma pri ?name; make_apply_entry env sigma flags pri ?name] in if ents = [] then errorlabstrm "Hint" @@ -345,7 +544,8 @@ let make_resolves env sigma flags pri 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 + ~name:(PathHints [VarRef hname]) (mkVar hname, htyp)] with | Failure _ -> [] @@ -353,26 +553,30 @@ let make_resolve_hyp env sigma (hname,_,htyp) = (* REM : in most cases hintname = id *) let make_unfold eref = - (Some (global_of_evaluable_reference eref), + let g = global_of_evaluable_reference eref in + (Some g, { pri = 4; pat = None; + name = PathHints [g]; code = Unfold_nth eref }) let make_extern pri pat tacast = let hdconstr = Option.map try_head_pattern pat in (hdconstr, - { pri=pri; + { pri = pri; pat = pat; - code= Extern tacast }) + name = PathAny; + code = Extern tacast }) -let make_trivial env sigma c = +let make_trivial env sigma ?(name=PathAny) c = let t = hnf_constr env sigma (type_of env sigma c) in let hd = head_of_constr_reference (fst (head_constr t)) in let ce = mk_clenv_from dummy_goal (c,t) in (Some hd, { pri=1; - pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce))); - code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) }) - + pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce))); + name = name; + code=Res_pf_THEN_trivial_fail(c,t) }) + open Vernacexpr (**************************************************************************) @@ -402,23 +606,39 @@ let add_transparency dbname grs b = st grs in searchtable_add (dbname, Hint_db.set_transparent_state db st') -type hint_action = | CreateDB of bool * transparent_state - | AddTransparency of evaluable_global_reference list * bool - | AddTactic of (global_reference option * pri_auto_tactic) list +let remove_hint dbname grs = + let db = get_db dbname in + let db' = Hint_db.remove_list grs db in + searchtable_add (dbname, db') + +type hint_action = + | CreateDB of bool * transparent_state + | AddTransparency of evaluable_global_reference list * bool + | AddHints of hint_entry list + | RemoveHints of global_reference list + | AddCut of hints_path + +let add_cut dbname path = + let db = get_db dbname in + let db' = Hint_db.add_cut path db in + searchtable_add (dbname, db') + +type hint_obj = bool * string * hint_action (* locality, name, action *) let cache_autohint (_,(local,name,hints)) = match hints with | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) | AddTransparency (grs, b) -> add_transparency name grs b - | AddTactic hints -> add_hint name hints + | AddHints hints -> add_hint name hints + | RemoveHints grs -> remove_hint name grs + | AddCut path -> add_cut name path let forward_subst_tactic = ref (fun _ -> failwith "subst_tactic is not installed for auto") let set_extern_subst_tactic f = forward_subst_tactic := f -let subst_autohint (subst,(local,name,hintlist as obj)) = - let trans_clenv clenv = Clenv.subst_clenv subst clenv in +let subst_autohint (subst,(local,name,hintlist as obj)) = let subst_key gr = let (lab'', elab') = subst_global subst gr in let gr' = @@ -428,90 +648,72 @@ let subst_autohint (subst,(local,name,hintlist as obj)) = in let subst_hint (k,data as hint) = let k' = Option.smartmap subst_key k in - let data' = match data.code with - | Res_pf (c, clenv) -> - let c' = subst_mps subst c in - let clenv' = trans_clenv clenv in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if c==c' && clenv'==clenv && pat'==data.pat then data else - {data with - pat=pat'; - code=Res_pf (c', clenv')} - | ERes_pf (c, clenv) -> - let c' = subst_mps subst c in - let clenv' = trans_clenv clenv in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if c==c' && clenv'==clenv && pat'==data.pat then data else - {data with - pat=pat'; - code=ERes_pf (c', clenv')} + let pat' = Option.smartmap (subst_pattern subst) data.pat in + let code' = match data.code with + | Res_pf (c,t) -> + 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) -> + 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 -> - let c' = subst_mps subst c in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if c==c' && pat'==data.pat then data else - {data with - pat=pat'; - code=(Give_exact c')} - | Res_pf_THEN_trivial_fail (c, clenv) -> - let c' = subst_mps subst c in - let clenv' = trans_clenv clenv in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if c==c' && clenv'==clenv && pat'==data.pat then data else - {data with - pat=pat'; - code=Res_pf_THEN_trivial_fail (c',clenv')} + 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 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') | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if ref==ref' && pat'==data.pat then data else - {data with - pat=pat'; - code=(Unfold_nth ref')} + if ref==ref' then data.code else Unfold_nth ref' | Extern tac -> let tac' = !forward_subst_tactic subst tac in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if tac==tac' && pat'==data.pat then data else - {data with - pat=pat'; - code=(Extern tac')} + if tac==tac' then data.code else Extern tac' in - if k' == k && data' == data then hint else - (k',data') + let data' = + if data.pat==pat' && data.code==code' then data + else { data with pat = pat'; code = code' } + in + if k' == k && data' == data then hint else (k',data') in match hintlist with | CreateDB _ -> obj | AddTransparency (grs, b) -> let grs' = list_smartmap (subst_evaluable_reference subst) grs in if grs==grs' then obj else (local, name, AddTransparency (grs', b)) - | AddTactic hintlist -> + | AddHints hintlist -> let hintlist' = list_smartmap subst_hint hintlist in if hintlist' == hintlist then obj else - (local,name,AddTactic hintlist') + (local,name,AddHints hintlist') + | RemoveHints grs -> + let grs' = list_smartmap (fun x -> fst (subst_global subst x)) grs in + if grs==grs' then obj else (local, name, RemoveHints grs') + | AddCut path -> + let path' = subst_hints_path subst path in + if path' == path then obj else (local, name, AddCut path') let classify_autohint ((local,name,hintlist) as obj) = - if local or hintlist = (AddTactic []) then Dispose else Substitute obj + if local or hintlist = (AddHints []) then Dispose else Substitute obj -let discharge_autohint (_,(local,name,hintlist as obj)) = - if local then None else - match hintlist with - | CreateDB _ -> - (* We assume that the transparent state is either empty or full *) - Some obj - | AddTransparency _ | AddTactic _ -> - (* Needs the adequate code here to support Global Hints in sections *) - None - -let (inAutoHint,_) = +let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with cache_function = cache_autohint; load_function = (fun _ -> cache_autohint); subst_function = subst_autohint; - classify_function = classify_autohint } - + classify_function = classify_autohint; } let create_hint_db l n st b = Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st))) +let remove_hints local dbnames grs = + let dbnames = if dbnames = [] then ["core"] else dbnames in + List.iter + (fun dbname -> + Lib.add_anonymous_leaf (inAutoHint(local, dbname, RemoveHints grs))) + dbnames + (**************************************************************************) (* The "Hint" vernacular command *) (**************************************************************************) @@ -520,16 +722,21 @@ let add_resolves env sigma clist local dbnames = (fun dbname -> Lib.add_anonymous_leaf (inAutoHint - (local,dbname, AddTactic - (List.flatten (List.map (fun (x, hnf, y) -> - make_resolves env sigma (true,hnf,Flags.is_verbose()) x y) clist))))) + (local,dbname, AddHints + (List.flatten (List.map (fun (x, hnf, path, y) -> + make_resolves env sigma (true,hnf,Flags.is_verbose()) x ~name:path y) clist))))) dbnames - let add_unfolds l local dbnames = List.iter (fun dbname -> Lib.add_anonymous_leaf - (inAutoHint (local,dbname, AddTactic (List.map make_unfold l)))) + (inAutoHint (local,dbname, AddHints (List.map make_unfold l)))) + dbnames + +let add_cuts l local dbnames = + List.iter + (fun dbname -> Lib.add_anonymous_leaf + (inAutoHint (local,dbname, AddCut l))) dbnames let add_transparency l b local dbnames = @@ -550,10 +757,10 @@ let add_extern pri pat tacast local dbname = (str "The meta-variable ?" ++ Ppconstr.pr_patvar i ++ str" is not bound.") | [] -> Lib.add_anonymous_leaf - (inAutoHint(local,dbname, AddTactic [make_extern pri (Some pat) tacast]))) + (inAutoHint(local,dbname, AddHints [make_extern pri (Some pat) tacast]))) | None -> Lib.add_anonymous_leaf - (inAutoHint(local,dbname, AddTactic [make_extern pri None tacast])) + (inAutoHint(local,dbname, AddHints [make_extern pri None tacast])) let add_externs pri pat tacast local dbnames = List.iter (add_extern pri pat tacast local) dbnames @@ -562,7 +769,8 @@ let add_trivials env sigma l local dbnames = List.iter (fun dbname -> Lib.add_anonymous_leaf ( - inAutoHint(local,dbname, AddTactic (List.map (make_trivial env sigma) l)))) + inAutoHint(local,dbname, + AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l)))) dbnames let forward_intern_tac = @@ -571,8 +779,9 @@ let forward_intern_tac = let set_extern_intern_tac f = forward_intern_tac := f type hints_entry = - | HintsResolveEntry of (int option * bool * constr) list - | HintsImmediateEntry of constr list + | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list + | HintsImmediateEntry of (hints_path_atom * constr) list + | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsExternEntry of @@ -580,24 +789,69 @@ type hints_entry = | HintsDestructEntry of identifier * int * (bool,unit) location * (patvar list * constr_pattern) * glob_tactic_expr +let h = id_of_string "H" + +exception Found of constr * types + +let prepare_hint env (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 + thing make_resolves will do is to re-instantiate the products *) + let c = drop_extra_implicit_args (Evarutil.nf_evar sigma c) in + let vars = ref (collect_vars c) in + let subst = ref [] in + let rec find_next_evar c = match kind_of_term c with + | Evar (evk,args as ev) -> + (* We skip the test whether args is the identity or not *) + let t = Evarutil.nf_evar sigma (existential_type sigma ev) in + let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in + if free_rels t <> Intset.empty then + error "Hints with holes dependent on a bound variable not supported."; + if occur_existential t then + (* Not clever enough to construct dependency graph of evars *) + error "Not clever enough to deal with evars dependent in other evars."; + raise (Found (c,t)) + | _ -> iter_constr find_next_evar c in + let rec iter c = + try find_next_evar c; c + with Found (evar,t) -> + let id = next_ident_away_from h (fun id -> Idset.mem id !vars) in + vars := Idset.add id !vars; + subst := (evar,mkVar id)::!subst; + mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in + iter c + +let path_of_constr_expr c = + match c with + | Topconstr.CRef r -> (try PathHints [global r] with _ -> PathAny) + | _ -> PathAny + let interp_hints h = - let f = Constrintern.interp_constr Evd.empty (Global.env()) in + 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 let fr r = let gr = global_with_alias r in let r' = evaluable_of_global_reference (Global.env()) gr in Dumpglob.add_glob (loc_of_reference r) gr; r' in + let fres (o, b, c) = (o, b, path_of_constr_expr c, f c) in + let fi c = path_of_constr_expr c, f c in let fp = Constrintern.intern_constr_pattern Evd.empty (Global.env()) in match h with - | HintsResolve lhints -> HintsResolveEntry (List.map (on_pi3 f) lhints) - | HintsImmediate lhints -> HintsImmediateEntry (List.map f lhints) + | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) + | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) | HintsTransparency (lhints, b) -> HintsTransparencyEntry (List.map fr lhints, b) | HintsConstructors lqid -> let constr_hints_of_ind qid = let ind = global_inductive_with_alias qid in - list_tabulate (fun i -> None, true, mkConstruct (ind,i+1)) + list_tabulate (fun i -> let c = (ind,i+1) in + None, true, PathHints [ConstructRef c], mkConstruct c) (nconstructors ind) in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> @@ -609,11 +863,14 @@ let interp_hints h = HintsDestructEntry (na,pri,loc,pat,!forward_intern_tac l code) let add_hints local dbnames0 h = + if List.mem "nocore" dbnames0 then + error "The hint database \"nocore\" is meant to stay empty."; let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in let env = Global.env() and sigma = Evd.empty in match h with | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames + | HintsCutEntry lhints -> add_cuts lhints local dbnames | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames | HintsTransparencyEntry (lhints, b) -> add_transparency lhints b local dbnames @@ -639,8 +896,8 @@ let pr_autotactic = | Extern tac -> (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) -let pr_hint v = - (pr_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ()) +let pr_hint (id, v) = + (pr_autotactic v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ()) let pr_hint_list hintlist = (str " " ++ hov 0 (prlist pr_hint hintlist) ++ fnl ()) @@ -655,7 +912,7 @@ let pr_hint_list_for_head c = let dbs = Hintdbmap.to_list !searchtable in let valid_dbs = map_succeed - (fun (name,db) -> (name,db,Hint_db.map_all c db)) + (fun (name,db) -> (name,db, List.map (fun v -> 0, v) (Hint_db.map_all c db))) dbs in if valid_dbs = [] then @@ -682,6 +939,7 @@ let pr_hint_term cl = else Hint_db.map_auto (hd, applist (hdc,args)) with Bound -> Hint_db.map_none in + let fn db = List.map (fun x -> 0, x) (fn db) in map_succeed (fun (name, db) -> (name, db, fn db)) dbs in if valid_dbs = [] then @@ -700,8 +958,12 @@ let print_hint_term cl = ppnl (pr_hint_term cl) (* print all hints that apply to the concl of the current goal *) let print_applicable_hint () = let pts = get_pftreestate () in - let gl = nth_goal_of_pftreestate 1 pts in - print_hint_term (pf_concl gl) + let glss = Proof.V82.subgoals pts in + match glss.Evd.it with + | [] -> Util.error "No focused goal." + | g::_ -> + let gl = { Evd.it = g; sigma = glss.Evd.sigma } in + print_hint_term (pf_concl gl) (* displays the whole hint database db *) let print_hint_db db = @@ -711,17 +973,18 @@ let print_hint_db db = else str"Non-discriminated database"))); msgnl (hov 2 (str"Unfoldable variable definitions: " ++ pr_idpred ids)); msgnl (hov 2 (str"Unfoldable constant definitions: " ++ pr_cpred csts)); + msgnl (hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db))); Hint_db.iter (fun head hintlist -> match head with | Some head -> msg (hov 0 (str "For " ++ pr_global head ++ str " -> " ++ - pr_hint_list hintlist)) + pr_hint_list (List.map (fun x -> (0,x)) hintlist))) | None -> msg (hov 0 (str "For any goal -> " ++ - pr_hint_list hintlist))) + pr_hint_list (List.map (fun x -> (0, x)) hintlist)))) db let print_hint_db_by_name dbname = @@ -746,7 +1009,7 @@ let print_searchtable () = (* tactics with a trace mechanism for automatic search *) (**************************************************************************) -let priority l = List.filter (fun (_,hint) -> hint.pri = 0) l +let priority l = List.filter (fun (_, hint) -> hint.pri = 0) l (* tell auto not to reuse already instantiated metas in unification (for compatibility, since otherwise, apply succeeds oftener) *) @@ -755,10 +1018,18 @@ open Unification let auto_unif_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly = false; + use_metas_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; + modulo_delta_types = full_transparent_state; + check_applied_meta_types = false; resolve_evars = true; - use_evars_pattern_unification = false; + use_pattern_unification = false; + use_meta_bound_pattern_unification = true; + frozen_evars = ExistentialSet.empty; + restrict_conv_on_strict_subterms = false; (* Compat *) + modulo_betaiota = false; + modulo_eta = true; + allow_K_in_toplevel_higher_order_unification = false } (* Try unification with the precompiled clause, then use registered Apply *) @@ -769,12 +1040,12 @@ let h_clenv_refine ev c clenv = let unify_resolve_nodelta (c,clenv) gl = let clenv' = connect_clenv gl clenv in - let clenv'' = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in + let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in h_clenv_refine false c clenv'' gl let unify_resolve flags (c,clenv) gl = let clenv' = connect_clenv gl clenv in - let clenv'' = clenv_unique_resolver false ~flags clenv' gl in + let clenv'' = clenv_unique_resolver ~flags clenv' gl in h_clenv_refine false c clenv'' gl let unify_resolve_gen = function @@ -783,40 +1054,44 @@ let unify_resolve_gen = function (* Util *) -let expand_constructor_hints lems = - list_map_append (fun lem -> +let expand_constructor_hints env lems = + list_map_append (fun (sigma,lem) -> match kind_of_term lem with | Ind ind -> list_tabulate (fun i -> mkConstruct (ind,i+1)) (nconstructors ind) | _ -> - [lem]) lems + [prepare_hint env (sigma,lem)]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types *) let add_hint_lemmas eapply lems hint_db gl = - let lems = expand_constructor_hints lems in + let lems = expand_constructor_hints (pf_env gl) lems in let hintlist' = list_map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in Hint_db.add_list hintlist' hint_db -let make_local_hint_db 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") + | Some ts -> ts + in let hintlist = list_map_append (pf_apply make_resolve_hyp gl) sign in add_hint_lemmas eapply lems - (Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false)) gl + (Hint_db.add_list hintlist (Hint_db.empty ts false)) 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 + substitution sans passer par bdize dont l'objectif est de préparer un terme pour l'affichage ? (HH) *) -(* Si on enlève le dernier argument (gl) conclPattern est calculé une +(* Si on enlève le dernier argument (gl) conclPattern est calculé une fois pour toutes : en particulier si Pattern.somatch produit une UserError -Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même -si après Intros la conclusion matche le pattern. +Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même +si après Intros la conclusion matche le pattern. *) -(* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) +(* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) let forward_interp_tactic = ref (fun _ -> failwith "interp_tactic is not installed for auto") @@ -837,8 +1112,8 @@ let conclPattern concl pat tac gl = (**************************************************************************) (* local_db is a Hint database containing the hypotheses of current goal *) -(* Papageno : cette fonction a été pas mal simplifiée depuis que la base - de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) +(* Papageno : cette fonction a été pas mal simplifiée depuis que la base + de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) let flags_of_state st = {auto_unif_flags with @@ -864,7 +1139,7 @@ let rec trivial_fail_db mod_delta db_list local_db gl = in tclFIRST (assumption::intro_tac:: - (List.map tclCOMPLETE + (List.map (fun tac -> tclCOMPLETE tac) (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl and my_find_search_nodelta db_list local_db hdc concl = @@ -876,7 +1151,7 @@ and my_find_search mod_delta = else my_find_search_nodelta and my_find_search_delta db_list local_db hdc concl = - let flags = {auto_unif_flags with use_metas_eagerly = true} in + let flags = {auto_unif_flags with use_metas_eagerly_in_conv_on_closed_terms = true} in let f = hintmap_of hdc concl in if occur_existential concl then list_map_append @@ -906,20 +1181,23 @@ 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 db_list local_db concl (flags, {pat=p; code=t}) = - match t with - | Res_pf (term,cl) -> unify_resolve_gen flags (term,cl) - | ERes_pf (_,c) -> (fun gl -> error "eres_pf") - | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> +and tac_of_hint db_list local_db concl (flags, ({pat=p; code=t})) = + let tactic = + match t with + | Res_pf (c,cl) -> unify_resolve_gen flags (c,cl) + | ERes_pf _ -> (fun gl -> error "eres_pf") + | Give_exact c -> exact_check c + | Res_pf_THEN_trivial_fail (c,cl) -> tclTHEN - (unify_resolve_gen flags (term,cl)) + (unify_resolve_gen flags (c,cl)) (trivial_fail_db (flags <> None) db_list local_db) - | Unfold_nth c -> (fun gl -> - if exists_evaluable_reference (pf_env gl) c then - tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl - else tclFAIL 0 (str"Unbound reference") gl) - | Extern tacast -> conclPattern concl p tacast + | Unfold_nth c -> + (fun gl -> + if exists_evaluable_reference (pf_env gl) c then + tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl + else tclFAIL 0 (str"Unbound reference") gl) + | Extern tacast -> conclPattern concl p tacast + in tactic and trivial_resolve mod_delta db_list local_db cl = try @@ -933,21 +1211,25 @@ and trivial_resolve mod_delta db_list local_db cl = (my_find_search mod_delta db_list local_db head cl)) with Not_found -> [] -let trivial lems dbnames gl = - let db_list = - List.map - (fun x -> - try - searchtable_map x - with Not_found -> - error_no_such_hint_database x) - ("core"::dbnames) +(** The use of the "core" database can be de-activated by passing + "nocore" amongst the databases. *) + +let make_db_list dbnames = + let use_core = not (List.mem "nocore" dbnames) in + let dbnames = list_remove "nocore" dbnames in + let dbnames = if use_core then "core"::dbnames else dbnames in + let lookup db = + try searchtable_map db with Not_found -> error_no_such_hint_database db in + List.map lookup dbnames + +let trivial lems dbnames gl = + let db_list = make_db_list dbnames in tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl let full_trivial lems gl = let dbnames = Hintdbmap.dom !searchtable in - let dbnames = list_subtract dbnames ["v62"] in + let dbnames = list_remove "v62" dbnames in let db_list = List.map (fun x -> searchtable_map x) dbnames in tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl @@ -955,10 +1237,8 @@ let gen_trivial lems = function | None -> full_trivial lems | Some l -> trivial lems l -let inj_open c = (Evd.empty,c) - let h_trivial lems l = - Refiner.abstract_tactic (TacTrivial (lems,l)) + Refiner.abstract_tactic (TacTrivial (List.map snd lems,l)) (gen_trivial lems l) (**************************************************************************) @@ -1051,15 +1331,7 @@ let search = search_gen 0 let default_search_depth = ref 5 let delta_auto mod_delta n lems dbnames gl = - let db_list = - List.map - (fun x -> - try - searchtable_map x - with Not_found -> - error_no_such_hint_database x) - ("core"::dbnames) - in + let db_list = make_db_list dbnames in tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl let auto = delta_auto false @@ -1070,7 +1342,7 @@ let default_auto = auto !default_search_depth [] [] let delta_full_auto mod_delta n lems gl = let dbnames = Hintdbmap.dom !searchtable in - let dbnames = list_subtract dbnames ["v62"] in + let dbnames = list_remove "v62" dbnames in let db_list = List.map (fun x -> searchtable_map x) dbnames in tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl @@ -1088,7 +1360,7 @@ let gen_auto n lems dbnames = let inj_or_var = Option.map (fun n -> ArgArg n) let h_auto n lems l = - Refiner.abstract_tactic (TacAuto (inj_or_var n,lems,l)) + Refiner.abstract_tactic (TacAuto (inj_or_var n,List.map snd lems,l)) (gen_auto n lems l) (**************************************************************************) @@ -1117,7 +1389,7 @@ let dauto (n,p) lems = let default_dauto = dauto (None,None) [] let h_dauto (n,p) lems = - Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,lems)) + Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,List.map snd lems)) (dauto (n,p) lems) (***************************************) diff --git a/tactics/auto.mli b/tactics/auto.mli index eef6a0ee..521c5ed2 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* hints_path +val path_matches : hints_path -> hints_path_atom list -> bool +val path_derivate : hints_path -> hints_path_atom -> hints_path +val pp_hints_path : hints_path -> Pp.std_ppcmds module Hint_db : sig @@ -58,12 +76,17 @@ module Hint_db : val map_auto : global_reference * constr -> t -> pri_auto_tactic list val add_one : hint_entry -> t -> t val add_list : (hint_entry) list -> t -> t - val iter : (global_reference option -> stored_data list -> unit) -> t -> unit + val remove_one : global_reference -> t -> t + val remove_list : global_reference list -> t -> t + val iter : (global_reference option -> pri_auto_tactic list -> unit) -> t -> unit val use_dn : t -> bool val transparent_state : t -> transparent_state val set_transparent_state : t -> transparent_state -> t + val add_cut : hints_path -> t -> t + val cut : t -> hints_path + val unfolds : t -> Idset.t * Cset.t end @@ -72,8 +95,9 @@ type hint_db_name = string type hint_db = Hint_db.t type hints_entry = - | HintsResolveEntry of (int option * bool * constr) list - | HintsImmediateEntry of constr list + | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list + | HintsImmediateEntry of (hints_path_atom * constr) list + | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsExternEntry of @@ -85,19 +109,23 @@ val searchtable_map : hint_db_name -> hint_db val searchtable_add : (hint_db_name * hint_db) -> unit -(* [create_hint_db local name st use_dn]. +(** [create_hint_db local name st use_dn]. [st] is a transparency state for unification using this db [use_dn] switches the use of the discrimination net for all hints and patterns. *) val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit +val remove_hints : bool -> hint_db_name list -> global_reference list -> unit + val current_db_names : unit -> hint_db_name list val interp_hints : hints_expr -> hints_entry val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit +val prepare_hint : env -> open_constr -> constr + val print_searchtable : unit -> unit val print_applicable_hint : unit -> unit @@ -108,13 +136,13 @@ val print_hint_db_by_name : hint_db_name -> unit val print_hint_db : Hint_db.t -> unit -(* [make_exact_entry pri (c, ctyp)]. +(** [make_exact_entry pri (c, ctyp)]. [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 -> constr * constr -> hint_entry +val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr * constr -> hint_entry -(* [make_apply_entry (eapply,verbose) pri (c,cty)]. +(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)]. [eapply] is true if this hint will be used only with EApply; [hnf] should be true if we should expand the head of cty before searching for products; @@ -122,21 +150,21 @@ val make_exact_entry : evar_map -> int option -> constr * constr -> hint_entry [cty] is the type of [c]. *) val make_apply_entry : - env -> evar_map -> bool * bool * bool -> int option -> constr * constr - -> hint_entry + env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> + constr * constr -> hint_entry -(* A constr which is Hint'ed will be: - (1) used as an Exact, if it does not start with a product - (2) used as an Apply, if its HNF starts with a product, and - has no missing arguments. - (3) used as an EApply, if its HNF starts with a product, and - has missing arguments. *) +(** A constr which is Hint'ed will be: + - (1) used as an Exact, if it does not start with a product + - (2) used as an Apply, if its HNF starts with a product, and + has no missing arguments. + - (3) used as an EApply, if its HNF starts with a product, and + has missing arguments. *) val make_resolves : - env -> evar_map -> bool * bool * bool -> int option -> constr -> - hint_entry list + env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> + constr -> hint_entry list -(* [make_resolve_hyp hname htyp]. +(** [make_resolve_hyp hname htyp]. used to add an hypothesis to the local hint database; Never raises a user exception; If the hyp cannot be used as a Hint, the empty list is returned. *) @@ -144,7 +172,7 @@ val make_resolves : val make_resolve_hyp : env -> evar_map -> named_declaration -> hint_entry list -(* [make_extern pri pattern tactic_expr] *) +(** [make_extern pri pattern tactic_expr] *) val make_extern : int -> constr_pattern option -> Tacexpr.glob_tactic_expr @@ -161,11 +189,11 @@ val set_extern_subst_tactic : (substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr) -> unit -(* Create a Hint database from the pairs (name, constr). +(** Create a Hint database from the pairs (name, constr). Useful to take the current goal hypotheses as hints; Boolean tells if lemmas with evars are allowed *) -val make_local_hint_db : bool -> constr list -> goal sigma -> hint_db +val make_local_hint_db : ?ts:transparent_state -> bool -> open_constr list -> goal sigma -> hint_db val priority : ('a * pri_auto_tactic) list -> ('a * pri_auto_tactic) list @@ -173,63 +201,69 @@ val default_search_depth : int ref val auto_unif_flags : Unification.unify_flags -(* Try unification with the precompiled clause, then use registered Apply *) +(** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve_nodelta : (constr * clausenv) -> tactic val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic -(* [ConclPattern concl pat tacast]: +(** [ConclPattern concl pat tacast]: if the term concl matches the pattern pat, (in sense of [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the right values to build a tactic *) val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> tactic -(* The Auto tactic *) +(** The Auto tactic *) -val auto : int -> constr list -> hint_db_name list -> tactic +(** The use of the "core" database can be de-activated by passing + "nocore" amongst the databases. *) -(* Auto with more delta. *) +val make_db_list : hint_db_name list -> hint_db list -val new_auto : int -> constr list -> hint_db_name list -> tactic +val auto : int -> open_constr list -> hint_db_name list -> tactic -(* auto with default search depth and with the hint database "core" *) +(** Auto with more delta. *) + +val new_auto : int -> open_constr list -> hint_db_name list -> tactic + +(** auto with default search depth and with the hint database "core" *) val default_auto : tactic -(* auto with all hint databases except the "v62" compatibility database *) -val full_auto : int -> constr list -> tactic +(** auto with all hint databases except the "v62" compatibility database *) +val full_auto : int -> open_constr list -> tactic -(* auto with all hint databases except the "v62" compatibility database +(** auto with all hint databases except the "v62" compatibility database and doing delta *) -val new_full_auto : int -> constr list -> tactic +val new_full_auto : int -> open_constr list -> tactic -(* auto with default search depth and with all hint databases +(** auto with default search depth and with all hint databases except the "v62" compatibility database *) val default_full_auto : tactic -(* The generic form of auto (second arg [None] means all bases) *) -val gen_auto : int option -> constr list -> hint_db_name list option -> tactic +(** The generic form of auto (second arg [None] means all bases) *) +val gen_auto : int option -> open_constr list -> hint_db_name list option -> tactic -(* The hidden version of auto *) -val h_auto : int option -> constr list -> hint_db_name list option -> tactic +(** The hidden version of auto *) +val h_auto : int option -> open_constr list -> hint_db_name list option -> tactic -(* Trivial *) -val trivial : constr list -> hint_db_name list -> tactic -val gen_trivial : constr list -> hint_db_name list option -> tactic -val full_trivial : constr list -> tactic -val h_trivial : constr list -> hint_db_name list option -> tactic +(** Trivial *) +val trivial : open_constr list -> hint_db_name list -> tactic +val gen_trivial : open_constr list -> hint_db_name list option -> tactic +val full_trivial : open_constr list -> tactic +val h_trivial : open_constr list -> hint_db_name list option -> tactic -val pr_autotactic : auto_tactic -> Pp.std_ppcmds +val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds -(*s The following is not yet up to date -- Papageno. *) +(** {6 The following is not yet up to date -- Papageno. } *) -(* DAuto *) -val dauto : int option * int option -> constr list -> tactic +(** DAuto *) +val dauto : int option * int option -> open_constr list -> tactic val default_search_decomp : int ref val default_dauto : tactic -val h_dauto : int option * int option -> constr list -> tactic -(* SuperAuto *) +val h_dauto : int option * int option -> open_constr list -> tactic + +(** SuperAuto *) type autoArguments = | UsingTDB @@ -241,4 +275,4 @@ val superauto : int -> (identifier * constr) list -> autoArguments list -> tacti val h_superauto : int option -> reference list -> bool -> bool -> tactic -val auto_init : (unit -> unit) ref +val add_auto_init : (unit -> unit) -> unit diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 2a41a8e5..a974c76a 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let tac = tac, conds in - general_rewrite dir all_occurrences false ~tac c) + general_rewrite dir all_occurrences true false ~tac c) tac_main bas)) tclIDTAC lbas)) @@ -132,16 +130,16 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic = let to_be_cleared = ref false in fun dir cstr tac gl -> let last_hyp_id = - match (Environ.named_context_of_val gl.Evd.it.Evd.evar_hyps) with + match Tacmach.pf_hyps gl with (last_hyp_id,_,_)::_ -> last_hyp_id | _ -> (* even the hypothesis id is missing *) error ("No such hypothesis: " ^ (string_of_id !id) ^".") in - let gl' = general_rewrite_in dir all_occurrences ~tac:(tac, conds) false !id cstr false gl in - let gls = (fst gl').Evd.it in + let gl' = general_rewrite_in dir all_occurrences true ~tac:(tac, conds) false !id cstr false gl in + let gls = gl'.Evd.it in match gls with g::_ -> - (match Environ.named_context_of_val g.Evd.evar_hyps with + (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with (lastid,_,_)::_ -> if last_hyp_id <> lastid then begin @@ -225,7 +223,7 @@ let classify_hintrewrite x = Libobject.Substitute x (* Declaration of the Hint Rewrite library object *) -let (inHintRewrite,_)= +let inHintRewrite : string * HintDN.t -> Libobject.obj = Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with Libobject.cache_function = cache_hintrewrite; Libobject.load_function = (fun _ -> cache_hintrewrite); @@ -248,7 +246,7 @@ type hypinfo = { let evd_convertible env evd x y = try - ignore(Unification.w_unify true env Reduction.CONV x y evd); true + ignore(Unification.w_unify ~flags:Unification.elim_flags env evd Reduction.CONV x y); true (* try ignore(Evarconv.the_conv_x env x y evd); true *) with _ -> false diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index ec285500..3205b041 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -1,34 +1,30 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_rew_rule list -> unit -(* The AutoRewrite tactic. +(** The AutoRewrite tactic. The optional conditions tell rewrite how to handle matching and side-condition solving. Default is Naive: first match in the clause, don't look at the side-conditions to tell if the rewrite succeeded. *) val autorewrite : ?conds:conditions -> tactic -> string list -> tactic val autorewrite_in : ?conds:conditions -> Names.identifier -> tactic -> string list -> tactic -(* Rewriting rules *) +(** Rewriting rules *) type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 119d8398..c13136b9 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* sig diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index 465d1d80..42df244d 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - Auto.create_hint_db false typeclasses_db full_transparent_state true) +let _ = + Auto.add_auto_init + (fun () -> Auto.create_hint_db false typeclasses_db full_transparent_state true) exception Found of evar_map -let is_dependent ev evm = - Evd.fold (fun ev' evi dep -> - if ev = ev' then dep - else dep || occur_evar ev evi.evar_concl) - evm false - -let valid goals p res_sigma l = - let evm = - List.fold_left2 - (fun sigma (ev, evi) prf -> - let cstr, obls = Refiner.extract_open_proof !res_sigma prf in - if not (Evd.is_defined sigma ev) then - Evd.define ev cstr sigma - else sigma) - !res_sigma goals l - in raise (Found evm) - -let evar_filter evi = - let hyps' = evar_filtered_context evi in - { evi with - evar_hyps = Environ.val_of_named_context hyps'; - evar_filter = List.map (fun _ -> true) hyps' } +(** We transform the evars that are concerned by this resolution + (according to predicate p) into goals. + Invariant: function p only manipulates undefined evars *) let evars_to_goals p evm = let goals, evm' = - Evd.fold + Evd.fold_undefined (fun ev evi (gls, evm') -> - if evi.evar_body = Evar_empty then - let evi', goal = p evm ev evi in - if goal then - ((ev, evi') :: gls, Evd.add evm' ev evi') - else (gls, Evd.add evm' ev evi') - else (gls, Evd.add evm' ev evi)) - evm ([], Evd.empty) + let evi', goal = p evm ev evi in + let gls' = if goal then (ev,Goal.V82.build ev) :: gls else gls in + (gls', Evd.add evm' ev evi')) + evm ([], Evd.defined_evars evm) in - if goals = [] then None - else - let goals = List.rev goals in - let evm' = evars_reset_evd ~with_conv_pbs:false evm' evm in - Some (goals, evm') + if goals = [] then None else Some (List.rev goals, evm') (** Typeclasses instance search tactic / eauto *) -let intersects s t = - Intset.exists (fun el -> Intset.mem el t) s - open Auto let e_give_exact flags c gl = let t1 = (pf_type_of gl c) in tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl -let assumption flags id = e_give_exact flags (mkVar id) - open Unification let auto_unif_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly = true; + use_metas_eagerly_in_conv_on_closed_terms = true; modulo_delta = var_full_transparent_state; + modulo_delta_types = full_transparent_state; + check_applied_meta_types = false; resolve_evars = false; - use_evars_pattern_unification = true; + use_pattern_unification = true; + use_meta_bound_pattern_unification = true; + frozen_evars = ExistentialSet.empty; + restrict_conv_on_strict_subterms = false; (* ? *) + modulo_betaiota = true; + modulo_eta = true; + allow_K_in_toplevel_higher_order_unification = false } let rec eq_constr_mod_evars x y = @@ -126,18 +103,18 @@ let progress_evars t gl = in tclTHEN t check gl TACTIC EXTEND progress_evars - [ "progress_evars" tactic(t) ] -> [ progress_evars (snd t) ] + [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.eval_tactic t) ] END let unify_e_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in - let clenv' = clenv_unique_resolver false ~flags clenv' gls in - tclPROGRESS (Clenvtac.clenv_refine true ~with_classes:false clenv') gls + 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 clenv' = clenv_unique_resolver false ~flags clenv' gls in - tclPROGRESS (Clenvtac.clenv_refine false ~with_classes:false clenv') gls + let clenv' = clenv_unique_resolver ~flags clenv' gls in + Clenvtac.clenv_refine false ~with_classes:false clenv' gls let clenv_of_prods nprods (c, clenv) gls = if nprods = 0 then Some clenv @@ -157,7 +134,9 @@ let with_prods nprods (c, clenv) f gls = let flags_of_state st = {auto_unif_flags with - modulo_conv_on_closed_terms = Some st; modulo_delta = st} + modulo_conv_on_closed_terms = Some st; modulo_delta = st; + modulo_delta_types = st; + modulo_eta = false} let rec e_trivial_fail_db db_list local_db goal = let tacl = @@ -168,11 +147,11 @@ let rec e_trivial_fail_db db_list local_db goal = let hintl = make_resolve_hyp (pf_env g') (project g') d in (e_trivial_fail_db db_list (Hint_db.add_list hintl local_db) g'))) :: - (List.map (fun (x,_,_,_) -> x) (e_trivial_resolve db_list local_db (pf_concl goal))) + (List.map (fun (x,_,_,_,_) -> x) (e_trivial_resolve db_list local_db (pf_concl goal))) in tclFIRST (List.map tclCOMPLETE tacl) goal -and e_my_find_search db_list local_db hdc concl = +and e_my_find_search db_list local_db hdc complete concl = let hdc = head_of_constr_reference hdc in let prods, concl = decompose_prod_assum concl in let nprods = List.length prods in @@ -188,7 +167,7 @@ and e_my_find_search db_list local_db hdc concl = (local_db::db_list) in let tac_of_hint = - fun (flags, {pri=b; pat = p; code=t}) -> + fun (flags, {pri = b; pat = p; code = t; name = name}) -> let tac = match t with | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve flags) @@ -196,66 +175,55 @@ and e_my_find_search db_list local_db hdc concl = | 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)) - (e_trivial_fail_db db_list local_db) + (if complete then tclIDTAC else e_trivial_fail_db db_list local_db) | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [all_occurrences,c]) - | Extern tacast -> conclPattern concl p tacast + | Extern tacast -> +(* tclTHEN *) +(* (fun gl -> Refiner.tclEVARS (mark_unresolvables (project gl)) gl) *) + (conclPattern concl p tacast) in + let tac = if complete then tclCOMPLETE tac else tac in match t with - | Extern _ -> (tac,b,true,lazy (pr_autotactic t)) - | _ -> (tac,b,false,lazy (pr_autotactic t)) + | Extern _ -> (tac,b,true, name, lazy (pr_autotactic t)) + | _ -> +(* let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *) + (tac,b,false, name, lazy (pr_autotactic t)) in List.map tac_of_hint hintl and e_trivial_resolve db_list local_db gl = try e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl + (fst (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)) gl + (fst (head_constr_bound gl)) false gl with Bound | Not_found -> [] let rec catchable = function | Refiner.FailError _ -> true - | Stdpp.Exc_located (_, e) -> catchable e + | Loc.Exc_located (_, e) -> catchable e | e -> Logic.catchable_exception e -let is_dep gl gls = - let evs = Evarutil.evars_of_term gl.evar_concl in - if evs = Intset.empty then false - else - List.fold_left - (fun b gl -> - if b then b - else - let evs' = Evarutil.evars_of_term gl.evar_concl in - intersects evs evs') - false gls - -let is_ground gl = - Evarutil.is_ground_term (project gl) (pf_concl gl) - let nb_empty_evars s = - Evd.fold (fun ev evi acc -> if evi.evar_body = Evar_empty then succ acc else acc) s 0 + Evd.fold_undefined (fun ev evi acc -> succ acc) s 0 -let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) - -let typeclasses_debug = ref false - -type validation = evar_map -> proof_tree list -> proof_tree +let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) let pr_depth l = prlist_with_sep (fun () -> str ".") pr_int (List.rev l) type autoinfo = { hints : Auto.hint_db; is_evar: existential_key option; - only_classes: bool; auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t} + only_classes: bool; auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t; + auto_path : global_reference option list; + auto_cut : hints_path } type autogoal = goal * autoinfo type 'ans fk = unit -> 'ans type ('a,'ans) sk = 'a -> 'ans fk -> 'ans type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans } -type auto_result = autogoal list sigma * validation +type auto_result = autogoal list sigma type atac = auto_result tac @@ -272,26 +240,67 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = if not (eq_constr ty' ar) then iscl env' ty' else false in - let keep = not only_classes || iscl env cty in - if keep then let c = mkVar id in - map_succeed - (fun f -> try f (c,cty) with UserError _ -> failwith "") - [make_exact_entry sigma pri; make_apply_entry env sigma flags pri] + let is_class = iscl env cty in + let keep = not only_classes || is_class in + if keep then + let c = mkVar id in + let name = PathHints [VarRef id] in + let hints = + if is_class then + let hints = build_subclasses ~check:false env sigma (VarRef id) None in + (list_map_append + (fun (pri, c) -> make_resolves env sigma + (true,false,Flags.is_verbose()) pri c) + hints) + else [] + in + (hints @ map_succeed + (fun f -> try f (c,cty) with UserError _ -> failwith "") + [make_exact_entry ~name sigma pri; make_apply_entry ~name env sigma flags pri]) else [] let pf_filtered_hyps gls = - evar_filtered_context (sig_it gls) + Goal.V82.hyps gls.Evd.sigma (sig_it gls) + +let make_hints g st only_classes sign = + let paths, hintlist = + List.fold_left + (fun (paths, hints) hyp -> + if is_section_variable (pi1 hyp) then (paths, hints) + else + let path, hint = + PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp + in + (PathOr (paths, path), hint @ hints)) + (PathEmpty, []) sign + in Hint_db.add_list hintlist (Hint_db.empty st true) + +let autogoal_hints_cache : (Environ.named_context_val * hint_db) option ref = ref None +let freeze () = !autogoal_hints_cache +let unfreeze v = autogoal_hints_cache := v +let init () = autogoal_hints_cache := None + +let _ = init () -let make_autogoal_hints only_classes ?(st=full_transparent_state) g = - let sign = pf_filtered_hyps g in - let hintlist = list_map_append (pf_apply make_resolve_hyp g st (true,false,false) only_classes None) sign in - Hint_db.add_list hintlist (Hint_db.empty st true) - +let _ = + Summary.declare_summary "autogoal-hints-cache" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } + +let make_autogoal_hints = + fun only_classes ?(st=full_transparent_state) g -> + let sign = pf_filtered_hyps g in + match freeze () with + | Some (sign', hints) when 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 (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} -> let res = try Some (tac {it=gl; sigma=s}) with e when catchable e -> None in match res with - | Some (gls,v) -> sk (f gls hints, fun _ -> v) fk + | Some gls -> sk (f gls hints) fk | None -> fk () } let intro_tac : atac = @@ -299,28 +308,22 @@ let intro_tac : atac = (fun {it = gls; sigma = s} info -> let gls' = List.map (fun g' -> - let env = evar_env g' in + let env = Goal.V82.env s g' in + let context = Environ.named_context_of_val (Goal.V82.hyps s g') in let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) - (true,false,false) info.only_classes None (List.hd (evar_context g')) in + (true,false,false) info.only_classes None (List.hd context) in let ldb = Hint_db.add_list hint info.hints in (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls in {it = gls'; sigma = s}) let normevars_tac : atac = - lift_tactic tclNORMEVAR - (fun {it = gls; sigma = s} info -> - let gls' = - List.map (fun g' -> - (g', { info with auto_last_tac = lazy (str"NORMEVAR") })) gls - in {it = gls'; sigma = s}) - - -let id_tac : atac = - { skft = fun sk fk {it = gl; sigma = s} -> - sk ({it = [gl]; sigma = s}, fun _ pfs -> List.hd pfs) fk } + { skft = fun sk fk {it = (gl, info); sigma = s} -> + let gl', sigma' = Goal.V82.nf_evar s gl in + let info' = { info with auto_last_tac = lazy (str"normevars") } in + sk {it = [gl', info']; sigma = sigma'} fk } (* Ordering of states is lexicographic on the number of remaining goals. *) -let compare (pri, _, _, (res, _)) (pri', _, _, (res', _)) = +let compare (pri, _, _, res) (pri', _, _, res') = let nbgoals s = List.length (sig_it s) + nb_empty_evars (sig_sig s) in @@ -331,131 +334,104 @@ let compare (pri, _, _, (res, _)) (pri', _, _, (res', _)) = let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = { skft = fun sk fk gls -> x.skft sk (fun () -> y.skft sk fk gls) gls } -let solve_tac (x : 'a tac) : 'a tac = - { skft = fun sk fk gls -> x.skft (fun ({it = gls},_ as res) fk -> - if gls = [] then sk res fk else fk ()) fk gls } - -let solve_unif_tac : atac = - { skft = fun sk fk {it = gl; sigma = s} -> - try let s' = Evarconv.consider_remaining_unif_problems (Global.env ()) s in - normevars_tac.skft sk fk ({it=gl; sigma=s'}) - with _ -> fk () } - let hints_tac hints = { skft = fun sk fk {it = gl,info; sigma = s} -> - let possible_resolve ((lgls,v) as res, pri, b, pp) = - (pri, pp, b, res) - in - let tacs = - let concl = gl.evar_concl in + let concl = Goal.V82.concl s gl in + let tacgl = {it = gl; sigma = s} in let poss = e_possible_resolve hints info.hints concl in - let l = - let tacgl = {it = gl; sigma = s} in - Util.list_map_append (fun (tac, pri, b, pptac) -> - try [tac tacgl, pri, b, pptac] with e when catchable e -> []) - poss - in - if l = [] && !typeclasses_debug then - msgnl (pr_depth info.auto_depth ++ str": no match for " ++ - Printer.pr_constr_env (Evd.evar_env gl) concl ++ - spc () ++ int (List.length poss) ++ str" possibilities"); - List.map possible_resolve l - in - let tacs = List.sort compare tacs in - let rec aux i = function - | (_, pp, b, ({it = gls; sigma = s}, v)) :: tl -> - if !typeclasses_debug then msgnl (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp - ++ str" on" ++ spc () ++ pr_ev s gl); - let fk = - (fun () -> (* if !typeclasses_debug then msgnl (str"backtracked after " ++ pp); *) - aux (succ i) tl) + let rec aux i foundone = function + | (tac, _, b, name, pp) :: tl -> + let derivs = path_derivate info.auto_cut name in + let res = + try + if path_matches derivs [] then None else Some (tac tacgl) + with e when catchable e -> None in - let sgls = evars_to_goals (fun evm ev evi -> - if Typeclasses.is_resolvable evi && - (not info.only_classes || Typeclasses.is_class_evar evm evi) then - Typeclasses.mark_unresolvable evi, true - else evi, false) s - in - let nbgls, newgls, s' = - let gls' = List.map (fun g -> (None, g)) gls in - match sgls with - | None -> List.length gls', gls', s - | Some (evgls, s') -> - (List.length gls', gls' @ List.map (fun (ev, x) -> (Some ev, x)) evgls, s') - in - let gls' = list_map_i (fun j (evar, g) -> - let info = - { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp; - is_evar = evar; - hints = - if b && g.evar_hyps <> gl.evar_hyps - then make_autogoal_hints info.only_classes - ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s'} - else info.hints } - in g, info) 1 newgls in - let glsv = {it = gls'; sigma = s'}, (fun _ pfl -> v (list_firstn nbgls pfl)) in - sk glsv fk - | [] -> fk () - in aux 1 tacs } - -let evars_of_term c = - let rec evrec acc c = - match kind_of_term c with - | Evar (n, _) -> Intset.add n acc - | _ -> fold_constr evrec acc c - in evrec Intset.empty c - -exception Found_evar of int - -let occur_evars evars c = - try - let rec evrec c = - match kind_of_term c with - | Evar (n, _) -> if Intset.mem n evars then raise (Found_evar n) else () - | _ -> iter_constr evrec c - in evrec c; false - with Found_evar _ -> true - -let dependent only_classes evd oev concl = - let concl_evars = Intset.union (evars_of_term concl) - (Option.cata Intset.singleton Intset.empty oev) - in not (Intset.is_empty concl_evars) + (match res with + | None -> aux i foundone tl + | Some {it = gls; sigma = s'} -> + if !typeclasses_debug then + msgnl (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp + ++ str" on" ++ spc () ++ pr_ev s gl); + let fk = + (fun () -> if !typeclasses_debug then msgnl (str"backtracked after " ++ Lazy.force pp); + aux (succ i) true tl) + in + let sgls = + evars_to_goals + (fun evm ev evi -> + if Typeclasses.is_resolvable evi && + (not info.only_classes || Typeclasses.is_class_evar evm evi) + then Typeclasses.mark_unresolvable evi, true + else evi, false) s' + in + let newgls, s' = + let gls' = List.map (fun g -> (None, g)) gls in + match sgls with + | None -> gls', s' + | Some (evgls, s') -> + (* Reorder with dependent subgoals. *) + (gls' @ List.map (fun (ev, x) -> Some ev, x) evgls, s') + in + let gls' = list_map_i + (fun j (evar, g) -> + let info = + { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp; + is_evar = evar; + hints = + if b && not (Environ.eq_named_context_val (Goal.V82.hyps s' g) (Goal.V82.hyps s' gl)) + then make_autogoal_hints info.only_classes + ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s'} + else info.hints; + auto_cut = derivs } + in g, info) 1 newgls in + let glsv = {it = gls'; sigma = s'} in + sk glsv fk) + | [] -> + if not foundone && !typeclasses_debug then + msgnl (pr_depth info.auto_depth ++ str": no match for " ++ + Printer.pr_constr_env (Goal.V82.env s gl) concl ++ + spc () ++ int (List.length poss) ++ str" possibilities"); + fk () + in aux 1 false poss } + +let isProp env sigma concl = + let ty = Retyping.get_type_of env sigma concl in + kind_of_term ty = Sort (Prop Null) + +let needs_backtrack only_classes env evd oev concl = + if oev = None || isProp env evd concl then + not (Intset.is_empty (Evarutil.evars_of_term concl)) + else true let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = - let rec aux s (acc : (autogoal list * validation) list) fk = function + let rec aux s (acc : autogoal list list) fk = function | (gl,info) :: gls -> - second.skft (fun ({it=gls';sigma=s'},v') fk' -> - let s', needs_backtrack = - if gls' = [] then - match info.is_evar with - | Some ev -> - let s' = - if Evd.is_defined s' ev then s' - else - let prf = v' s' [] in - let term, _ = Refiner.extract_open_proof s' prf in - Evd.define ev term s' - in s', dependent info.only_classes s' (Some ev) gl.evar_concl - | None -> s', dependent info.only_classes s' None gl.evar_concl - else s', true - in - let fk'' = if not needs_backtrack then - (if !typeclasses_debug then msgnl (str"no backtrack on " ++ pr_ev s gl); fk) else fk' - in aux s' ((gls',v')::acc) fk'' gls) - fk {it = (gl,info); sigma = s} + (match info.is_evar with + | Some ev when Evd.is_defined s ev -> aux s acc fk gls + | _ -> + second.skft + (fun {it=gls';sigma=s'} fk' -> + let needs_backtrack = + if gls' = [] then + needs_backtrack info.only_classes + (Goal.V82.env s gl) s' info.is_evar (Goal.V82.concl s gl) + else true + in + let fk'' = + if not needs_backtrack then + (if !typeclasses_debug then msgnl (str"no backtrack on " ++ pr_ev s gl ++ + str " after " ++ Lazy.force info.auto_last_tac); fk) + else fk' + in aux s' (gls'::acc) fk'' gls) + fk {it = (gl,info); sigma = s}) | [] -> Some (List.rev acc, s, fk) - in fun ({it = gls; sigma = s},v) fk -> + in fun {it = gls; sigma = s} fk -> let rec aux' = function | None -> fk () | Some (res, s', fk') -> - let goals' = List.concat (List.map (fun (gls,v) -> gls) res) in - let v' s' pfs' : proof_tree = - let (newpfs, rest) = List.fold_left (fun (newpfs,pfs') (gls,v) -> - let before, after = list_split_at (List.length gls) pfs' in - (v s' before :: newpfs, after)) - ([], pfs') res - in assert(rest = []); v s' (List.rev newpfs) - in sk ({it = goals'; sigma = s'}, v') (fun () -> aux' (fk' ())) + let goals' = List.concat res in + sk {it = goals'; sigma = s'} (fun () -> aux' (fk' ())) in aux' (aux s [] (fun () -> None) gls) let then_tac (first : atac) (second : atac) : atac = @@ -468,52 +444,68 @@ type run_list_res = (auto_result * run_list_res fk) option let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = (then_list t (fun x fk -> Some (x, fk))) - (gl, fun s pfs -> valid goals p (ref s) pfs) + gl (fun _ -> None) +let fail_tac : atac = + { skft = fun sk fk _ -> fk () } + let rec fix (t : 'a tac) : 'a tac = then_tac t { skft = fun sk fk -> (fix t).skft sk fk } -let make_autogoal ?(only_classes=true) ?(st=full_transparent_state) ev g = +let rec fix_limit limit (t : 'a tac) : 'a tac = + if limit = 0 then fail_tac + else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } + +let make_autogoal ?(only_classes=true) ?(st=full_transparent_state) cut ev g = let hints = make_autogoal_hints only_classes ~st g in (g.it, { hints = hints ; is_evar = ev; - only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (mt()) }) + only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none"); + auto_path = []; auto_cut = cut }) -let make_autogoals ?(only_classes=true) ?(st=full_transparent_state) gs evm' = + +let cut_of_hints h = + List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h + +let make_autogoals ?(only_classes=true) ?(st=full_transparent_state) hints gs evm' = + let cut = cut_of_hints hints in { it = list_map_i (fun i g -> - let (gl, auto) = make_autogoal ~only_classes ~st (Some (fst g)) {it = snd g; sigma = evm'} in + let (gl, auto) = make_autogoal ~only_classes ~st cut (Some (fst g)) {it = snd g; sigma = evm'} in (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm' } let get_result r = match r with | None -> None - | Some ((gls, v), fk) -> - try ignore(v (sig_sig gls) []); assert(false) - with Found evm' -> Some (evm', fk) - -let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm tac = + | Some (gls, fk) -> Some (gls.sigma,fk) + +let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm hints tac = match evars_to_goals p evm with | None -> None (* This happens only because there's no evar having p *) | Some (goals, evm') -> - let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st goals evm') in + 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 evm' evm, fk) + | Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true evm' evm, fk) let eauto_tac hints = - fix (or_tac (then_tac normevars_tac (hints_tac hints)) intro_tac) - -let eauto ?(only_classes=true) ?st hints g = - let gl = { it = make_autogoal ~only_classes ?st None g; sigma = project g } in - match run_tac (eauto_tac hints) gl with + then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) + +let eauto_tac ?limit hints = + match limit with + | None -> fix (eauto_tac hints) + | Some limit -> fix_limit limit (eauto_tac hints) + +let eauto ?(only_classes=true) ?st ?limit hints g = + let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g } in + match run_tac (eauto_tac ?limit hints) gl with | None -> raise Not_found - | Some ({it = goals; sigma = s}, valid) -> - {it = List.map fst goals; sigma = s}, valid s + | Some {it = goals; sigma = s} -> + {it = List.map fst goals; sigma = s} -let real_eauto st hints p evd = +let real_eauto st ?limit hints p evd = let rec aux evd fails = let res, fails = - try run_on_evars ~st p evd (eauto_tac hints), fails + try run_on_evars ~st p evd hints (eauto_tac ?limit hints), fails with Not_found -> List.fold_right (fun fk (res, fails) -> match res with @@ -526,162 +518,209 @@ let real_eauto st hints p evd = | Some (evd', fk) -> aux evd' (fk :: fails) in aux evd [] -let resolve_all_evars_once debug (mode, depth) p evd = +let resolve_all_evars_once debug limit p evd = let db = searchtable_map typeclasses_db in - real_eauto (Hint_db.transparent_state db) [db] p evd + real_eauto ?limit (Hint_db.transparent_state db) [db] p evd + +(** We compute dependencies via a union-find algorithm. + Beware of the imperative effects on the partition structure, + it should not be shared, but only used locally. *) + +module Intpart = Unionfind.Make(Intset)(Intmap) -exception FoundTerm of constr +let deps_of_constraints cstrs evm p = + List.iter (fun (_, _, x, y) -> + let evx = Evarutil.undefined_evars_of_term evm x in + let evy = Evarutil.undefined_evars_of_term evm y in + Intpart.union_set (Intset.union evx evy) p) + cstrs + +let evar_dependencies evm p = + Evd.fold_undefined + (fun ev evi _ -> + let evars = Intset.add ev (Evarutil.undefined_evars_of_evar_info evm evi) + in Intpart.union_set evars p) + evm () let resolve_one_typeclass env ?(sigma=Evd.empty) gl = - let gls = { it = Evd.make_evar (Environ.named_context_val env) gl; sigma = sigma } in + let nc, gl, subst, _ = Evarutil.push_rel_context_to_named_context env gl in + let (gl,t,sigma) = + Goal.V82.mk_goal sigma nc gl Store.empty in + let gls = { it = gl ; sigma = sigma } in let hints = searchtable_map typeclasses_db in - let gls', v = eauto ~st:(Hint_db.transparent_state hints) [hints] gls in - let term = v [] in + let gls' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in let evd = sig_sig gls' in - let term = fst (Refiner.extract_open_proof evd term) in - let term = Evarutil.nf_evar evd term in + let t' = let (ev, inst) = destEvar t in + mkEvar (ev, Array.of_list subst) + in + let term = Evarutil.nf_evar evd t' in evd, term let _ = Typeclasses.solve_instanciation_problem := (fun x y z -> resolve_one_typeclass x ~sigma:y z) -let has_undefined p oevd evd = - Evd.fold (fun ev evi has -> has || - (evi.evar_body = Evar_empty && snd (p oevd ev evi))) - evd false - -let rec merge_deps deps = function - | [] -> [deps] - | hd :: tl -> - if intersects deps hd then - merge_deps (Intset.union deps hd) tl - else hd :: merge_deps deps tl - -let evars_of_evi evi = - Intset.union (evars_of_term evi.evar_concl) - (Intset.union - (match evi.evar_body with - | Evar_empty -> Intset.empty - | Evar_defined b -> evars_of_term b) - (Evarutil.evars_of_named_context (evar_filtered_context evi))) - -let deps_of_constraints cstrs deps = - List.fold_right (fun (_, _, x, y) deps -> - let evs = Intset.union (evars_of_term x) (evars_of_term y) in - merge_deps evs deps) - cstrs deps - -let evar_dependencies evm = - Evd.fold - (fun ev evi acc -> - merge_deps (Intset.union (Intset.singleton ev) - (evars_of_evi evi)) acc) - evm [] +(** [split_evars] returns groups of undefined evars according to dependencies *) let split_evars evm = - let _, cstrs = extract_all_conv_pbs evm in - let evmdeps = evar_dependencies evm in - let deps = deps_of_constraints cstrs evmdeps in - List.sort Intset.compare deps + let p = Intpart.create () in + evar_dependencies evm p; + deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p; + Intpart.partition p + +(** [evars_in_comp] filters an [evar_map], keeping only evars + that belongs to a certain component *) -let select_evars evs evm = - Evd.fold (fun ev evi acc -> - if Intset.mem ev evs then Evd.add acc ev evi else acc) - evm Evd.empty +let evars_in_comp comp evm = + try + evars_reset_evd + (Intset.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evm ev)) + comp Evd.empty) evm + with Not_found -> assert false -let is_inference_forced p ev evd = +let is_inference_forced p evd ev = try - let evi = Evd.find evd ev in - if evi.evar_body = Evar_empty then - if Typeclasses.is_resolvable evi - && snd (p ev evi) - then - let (loc, k) = evar_source ev evd in - match k with - | ImplicitArg (_, _, b) -> b - | QuestionMark _ -> false - | _ -> true - else true - else false - with Not_found -> true - -let is_optional p comp evd = - Intset.fold (fun ev acc -> - acc && not (is_inference_forced p ev evd)) - comp true + let evi = Evd.find_undefined evd ev in + if Typeclasses.is_resolvable evi && snd (p ev evi) + then + let (loc, k) = evar_source ev evd in + match k with + | ImplicitArg (_, _, b) -> b + | QuestionMark _ -> false + | _ -> true + else true + with Not_found -> assert false + +let is_mandatory p comp evd = + Intset.exists (is_inference_forced p evd) comp + +(** In case of unsatisfiable constraints, build a nice error message *) + +let error_unresolvable env comp do_split evd = + let evd = Evarutil.nf_evar_map_undefined evd in + let evm = if do_split then evars_in_comp comp evd else evd in + let _, ev = Evd.fold_undefined + (fun ev evi (b,acc) -> + (* focus on one instance if only one was searched for *) + if class_of_constr evi.evar_concl <> None then + if not b (* || do_split *) then + true, Some ev + else b, None + else b, acc) evm (false, None) + in + Typeclasses_errors.unsatisfiable_constraints + (Evarutil.nf_env_evar evm env) evm ev + +(** Check if an evar is concerned by the current resolution attempt, + (and in particular is in the current component), and also update + its evar_info. + Invariant : this should only be applied to undefined evars, + and return undefined evar_info *) + +let select_and_update_evars p oevd in_comp evd ev evi = + assert (evi.evar_body = Evar_empty); + try + let oevi = Evd.find_undefined oevd ev in + if Typeclasses.is_resolvable oevi then + Typeclasses.mark_unresolvable evi, + (in_comp ev && p evd ev evi) + else evi, false + with Not_found -> + Typeclasses.mark_unresolvable evi, p evd ev evi + +(** Do we still have unresolved evars that should be resolved ? *) + +let has_undefined p oevd evd = + Evd.fold_undefined (fun ev evi has -> has || + snd (p oevd ev evi)) + evd false + +(** If [do_split] is [true], we try to separate the problem in + several components and then solve them separately *) + +exception Unresolved let resolve_all_evars debug m env p oevd do_split fail = let split = if do_split then split_evars oevd else [Intset.empty] in - let p = if do_split then - fun comp evd ev evi -> - if evi.evar_body = Evar_empty then - (try let oevi = Evd.find oevd ev in - if Typeclasses.is_resolvable oevi then - Typeclasses.mark_unresolvable evi, (Intset.mem ev comp && - p evd ev evi) - else evi, false - with Not_found -> - Typeclasses.mark_unresolvable evi, p evd ev evi) - else evi, false - else fun _ evd ev evi -> - if evi.evar_body = Evar_empty then - try let oevi = Evd.find oevd ev in - if Typeclasses.is_resolvable oevi then - Typeclasses.mark_unresolvable evi, p evd ev evi - else evi, false - with Not_found -> - Typeclasses.mark_unresolvable evi, p evd ev evi - else evi, false - in - let rec aux p evd = - let evd' = resolve_all_evars_once debug m p evd in - if has_undefined p oevd evd' then None - else Some evd' + let in_comp comp ev = if do_split then Intset.mem ev comp else true in let rec docomp evd = function | [] -> evd | comp :: comps -> - let res = try aux (p comp) evd with Not_found -> None in - match res with - | None -> - if fail && (not do_split || not (is_optional (p comp evd) comp evd)) then - (* Unable to satisfy the constraints. *) - let evd = Evarutil.nf_evars evd in - let evm = if do_split then select_evars comp evd else evd in - let _, ev = Evd.fold - (fun ev evi (b,acc) -> - (* focus on one instance if only one was searched for *) - if class_of_constr evi.evar_concl <> None then - if not b (* || do_split *) then - true, Some ev - else b, None - else b, acc) evm (false, None) - in - Typeclasses_errors.unsatisfiable_constraints (Evarutil.nf_env_evar evm env) evm ev - else (* Best effort: do nothing *) oevd - | Some evd' -> docomp evd' comps + let p = select_and_update_evars p oevd (in_comp comp) in + try + let evd' = resolve_all_evars_once debug m p evd in + if has_undefined p oevd evd' then raise Unresolved; + docomp evd' comps + with Unresolved | Not_found -> + if fail && (not do_split || is_mandatory (p evd) comp evd) + then (* Unable to satisfy the constraints. *) + error_unresolvable env comp do_split evd + else (* Best effort: do nothing on this component *) + docomp evd comps in docomp oevd split -let resolve_typeclass_evars d p env evd onlyargs split fail = - let pred = - if onlyargs then - (fun evd ev evi -> Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) && - Typeclasses.is_class_evar evd evi) - else (fun evd ev evi -> Typeclasses.is_class_evar evd evi) - in resolve_all_evars d p env pred evd split fail +let initial_select_evars onlyargs = + if onlyargs then + (fun evd ev evi -> + Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) + && Typeclasses.is_class_evar evd evi) + else + (fun evd ev evi -> Typeclasses.is_class_evar evd evi) + +let resolve_typeclass_evars debug m env evd onlyargs split fail = + let evd = + try Evarconv.consider_remaining_unif_problems + ~ts:(Typeclasses.classes_transparent_state ()) env evd + with _ -> evd + in + resolve_all_evars debug m env (initial_select_evars onlyargs) evd split fail -let solve_inst debug mode depth env evd onlyargs split fail = - resolve_typeclass_evars debug (mode, depth) env evd onlyargs split fail +let solve_inst debug depth env evd onlyargs split fail = + resolve_typeclass_evars debug depth env evd onlyargs split fail let _ = Typeclasses.solve_instanciations_problem := - solve_inst false true default_eauto_depth + solve_inst false !typeclasses_depth + + +(** Options: depth, debug and transparency settings. *) + +open Goptions + +let set_typeclasses_debug d = (:=) typeclasses_debug d; + Typeclasses.solve_instanciations_problem := solve_inst d !typeclasses_depth + +let get_typeclasses_debug () = !typeclasses_debug + +let set_typeclasses_debug = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "debug output for typeclasses proof search"; + optkey = ["Typeclasses";"Debug"]; + optread = get_typeclasses_debug; + optwrite = set_typeclasses_debug; } + + +let set_typeclasses_depth d = (:=) typeclasses_depth d; + Typeclasses.solve_instanciations_problem := solve_inst !typeclasses_debug !typeclasses_depth + +let get_typeclasses_depth () = !typeclasses_depth + +let set_typeclasses_depth = + declare_int_option + { optsync = true; + optdepr = false; + optname = "depth for typeclasses proof search"; + optkey = ["Typeclasses";"Depth"]; + optread = get_typeclasses_depth; + optwrite = set_typeclasses_depth; } let set_transparency cl b = List.iter (fun r -> let gr = Smartlocate.global_with_alias r in let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in - Classes.set_typeclass_transparency ev b) cl + Classes.set_typeclass_transparency ev false b) cl VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings | [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ @@ -704,18 +743,6 @@ ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug | [ ] -> [ false ] END -let pr_mode _prc _prlc _prt m = - match m with - Some b -> - if b then Pp.str "depth-first" else Pp.str "breadth-fist" - | None -> Pp.mt() - -ARGUMENT EXTEND search_mode TYPED AS bool option PRINTED BY pr_mode -| [ "dfs" ] -> [ Some true ] -| [ "bfs" ] -> [ Some false ] -| [] -> [ None ] -END - let pr_depth _prc _prlc _prt = function Some i -> Util.pr_int i | None -> Pp.mt() @@ -724,13 +751,12 @@ ARGUMENT EXTEND depth TYPED AS int option PRINTED BY pr_depth | [ int_or_var_opt(v) ] -> [ match v with Some (ArgArg i) -> Some i | _ -> None ] END +(* true = All transparent, false = Opaque if possible *) + VERNAC COMMAND EXTEND Typeclasses_Settings - | [ "Typeclasses" "eauto" ":=" debug(d) search_mode(s) depth(depth) ] -> [ - typeclasses_debug := d; - let mode = match s with Some t -> t | None -> true in - let depth = match depth with Some i -> i | None -> default_eauto_depth in - Typeclasses.solve_instanciations_problem := - solve_inst d mode depth + | [ "Typeclasses" "eauto" ":=" debug(d) depth(depth) ] -> [ + set_typeclasses_debug d; + set_typeclasses_depth depth ] END @@ -738,8 +764,8 @@ let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl try let dbs = list_map_filter (fun db -> try Some (Auto.searchtable_map db) with _ -> None) dbs in let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in - eauto ~only_classes ~st dbs gl - with Not_found -> tclFAIL 0 (str" typeclasses eauto failed") gl + eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl + with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl TACTIC EXTEND typeclasses_eauto | [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ typeclasses_eauto l ] diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index f459a3dd..a3d43623 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* tactic val contradiction : constr with_bindings option -> tactic diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml deleted file mode 100644 index c4cff4d7..00000000 --- a/tactics/decl_interp.ml +++ /dev/null @@ -1,472 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Thesis n - | This c -> This (intern_constr globs c) - -let add_var id globs= - let l1,l2=globs.ltacvars in - {globs with ltacvars= (id::l1),(id::l2)} - -let add_name nam globs= - match nam with - Anonymous -> globs - | Name id -> add_var id globs - -let intern_hyp iconstr globs = function - Hvar (loc,(id,topt)) -> add_var id globs, - Hvar (loc,(id,Option.map (intern_constr globs) topt)) - | Hprop st -> add_name st.st_label globs, - Hprop (intern_statement iconstr globs st) - -let intern_hyps iconstr globs hyps = - snd (list_fold_map (intern_hyp iconstr) globs hyps) - -let intern_cut intern_it globs cut= - let nglobs,nstat=intern_it globs cut.cut_stat in - {cut_stat=nstat; - cut_by=intern_justification_items nglobs cut.cut_by; - cut_using=intern_justification_method nglobs cut.cut_using} - -let intern_casee globs = function - Real c -> Real (intern_constr globs c) - | Virtual cut -> Virtual - (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) - -let intern_hyp_list args globs = - let intern_one globs (loc,(id,opttyp)) = - (add_var id globs), - (loc,(id,Option.map (intern_constr globs) opttyp)) in - list_fold_map intern_one globs args - -let intern_suffices_clause globs (hyps,c) = - let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in - nglobs,(nhyps,intern_constr_or_thesis nglobs c) - -let intern_fundecl args body globs= - let nglobs,nargs = intern_hyp_list args globs in - nargs,intern_constr nglobs body - -let rec add_vars_of_simple_pattern globs = function - CPatAlias (loc,p,id) -> - add_vars_of_simple_pattern (add_var id globs) p -(* Stdpp.raise_with_loc loc - (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) - | CPatOr (loc, _)-> - Stdpp.raise_with_loc loc - (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) - | CPatDelimiters (_,_,p) -> - add_vars_of_simple_pattern globs p - | CPatCstr (_,_,pl) -> - List.fold_left add_vars_of_simple_pattern globs pl - | CPatNotation(_,_,(pl,pll)) -> - List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll)) - | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs - | _ -> globs - -let rec intern_bare_proof_instr globs = function - Pthus i -> Pthus (intern_bare_proof_instr globs i) - | Pthen i -> Pthen (intern_bare_proof_instr globs i) - | Phence i -> Phence (intern_bare_proof_instr globs i) - | Pcut c -> Pcut - (intern_cut - (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c) - | Psuffices c -> - Psuffices (intern_cut intern_suffices_clause globs c) - | Prew (s,c) -> Prew - (s,intern_cut - (intern_no_bind (intern_statement intern_constr)) globs c) - | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps) - | Pcase (params,pat,hyps) -> - let nglobs,nparams = intern_hyp_list params globs in - let nnglobs= add_vars_of_simple_pattern nglobs pat in - let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in - Pcase (nparams,pat,nhyps) - | Ptake witl -> Ptake (List.map (intern_constr globs) witl) - | Pconsider (c,hyps) -> Pconsider (intern_constr globs c, - intern_hyps intern_constr globs hyps) - | Pper (et,c) -> Pper (et,intern_casee globs c) - | Pend bt -> Pend bt - | Pescape -> Pescape - | Passume hyps -> Passume (intern_hyps intern_constr globs hyps) - | Pgiven hyps -> Pgiven (intern_hyps intern_constr globs hyps) - | Plet hyps -> Plet (intern_hyps intern_constr globs hyps) - | Pclaim st -> Pclaim (intern_statement intern_constr globs st) - | Pfocus st -> Pfocus (intern_statement intern_constr globs st) - | Pdefine (id,args,body) -> - let nargs,nbody = intern_fundecl args body globs in - Pdefine (id,nargs,nbody) - | Pcast (id,typ) -> - Pcast (id,intern_constr globs typ) - -let rec intern_proof_instr globs instr= - {emph = instr.emph; - instr = intern_bare_proof_instr globs instr.instr} - -(* INTERP *) - -let interp_justification_items sigma env = - Option.map (List.map (fun c ->understand sigma env (fst c))) - -let interp_constr check_sort sigma env c = - if check_sort then - understand_type sigma env (fst c) - else - understand sigma env (fst c) - -let special_whd env = - let infos=Closure.create_clos_infos Closure.betadeltaiota env in - (fun t -> Closure.whd_val infos (Closure.inject t)) - -let _eq = Libnames.constr_of_global (Coqlib.glob_eq) - -let decompose_eq env id = - let typ = Environ.named_type id env in - let whd = special_whd env typ in - match kind_of_term whd with - App (f,args)-> - if eq_constr f _eq && (Array.length args)=3 - then args.(0) - else error "Previous step is not an equality." - | _ -> error "Previous step is not an equality." - -let get_eq_typ info env = - let typ = decompose_eq env (get_last env) in - typ - -let interp_constr_in_type typ sigma env c = - understand sigma env (fst c) ~expected_type:typ - -let interp_statement interp_it sigma env st = - {st_label=st.st_label; - st_it=interp_it sigma env st.st_it} - -let interp_constr_or_thesis check_sort sigma env = function - Thesis n -> Thesis n - | This c -> This (interp_constr check_sort sigma env c) - -let abstract_one_hyp inject h raw = - match h with - Hvar (loc,(id,None)) -> - RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw) - | Hvar (loc,(id,Some typ)) -> - RProd (dummy_loc,Name id, Explicit, fst typ, raw) - | Hprop st -> - RProd (dummy_loc,st.st_label, Explicit, inject st.st_it, raw) - -let rawconstr_of_hyps inject hyps head = - List.fold_right (abstract_one_hyp inject) hyps head - -let raw_prop = RSort (dummy_loc,RProp Null) - -let rec match_hyps blend names constr = function - [] -> [],substl names constr - | hyp::q -> - let (name,typ,body)=destProd constr in - let st= {st_label=name;st_it=substl names typ} in - let qnames= - match name with - Anonymous -> mkMeta 0 :: names - | Name id -> mkVar id :: names in - let qhyp = match hyp with - Hprop st' -> Hprop (blend st st') - | Hvar _ -> Hvar st in - let rhyps,head = match_hyps blend qnames body q in - qhyp::rhyps,head - -let interp_hyps_gen inject blend sigma env hyps head = - let constr=understand sigma env (rawconstr_of_hyps inject hyps head) in - match_hyps blend [] constr hyps - -let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps raw_prop) - -let dummy_prefix= id_of_string "__" - -let rec deanonymize ids = - function - PatVar (loc,Anonymous) -> - let (found,known) = !ids in - let new_id=Namegen.next_ident_away dummy_prefix known in - let _= ids:= (loc,new_id) :: found , new_id :: known in - PatVar (loc,Name new_id) - | PatVar (loc,Name id) as pat -> - let (found,known) = !ids in - let _= ids:= (loc,id) :: found , known in - pat - | PatCstr(loc,cstr,lpat,nam) -> - PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam) - -let rec raw_of_pat = - function - PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" - | PatVar (loc,Name id) -> - RVar (loc,id) - | PatCstr(loc,((ind,_) as cstr),lpat,_) -> - let mind= fst (Global.lookup_inductive ind) in - let rec add_params n q = - if n<=0 then q else - add_params (pred n) (RHole(dummy_loc, - Evd.TomatchTypeParameter(ind,n))::q) in - let args = List.map raw_of_pat lpat in - raw_app(loc,RRef(dummy_loc,Libnames.ConstructRef cstr), - add_params mind.Declarations.mind_nparams args) - -let prod_one_hyp = function - (loc,(id,None)) -> - (fun raw -> - RProd (dummy_loc,Name id, Explicit, - RHole (loc,Evd.BinderType (Name id)), raw)) - | (loc,(id,Some typ)) -> - (fun raw -> - RProd (dummy_loc,Name id, Explicit, fst typ, raw)) - -let prod_one_id (loc,id) raw = - RProd (dummy_loc,Name id, Explicit, - RHole (loc,Evd.BinderType (Name id)), raw) - -let let_in_one_alias (id,pat) raw = - RLetIn (dummy_loc,Name id, raw_of_pat pat, raw) - -let rec bind_primary_aliases map pat = - match pat with - PatVar (_,_) -> map - | PatCstr(loc,_,lpat,nam) -> - let map1 = - match nam with - Anonymous -> map - | Name id -> (id,pat)::map - in - List.fold_left bind_primary_aliases map1 lpat - -let bind_secondary_aliases map subst = - List.fold_left (fun map (ids,idp) -> (ids,List.assoc idp map)::map) map subst - -let bind_aliases patvars subst patt = - let map = bind_primary_aliases [] patt in - let map1 = bind_secondary_aliases map subst in - List.rev map1 - -let interp_pattern env pat_expr = - let patvars,pats = Constrintern.intern_pattern env pat_expr in - match pats with - [] -> anomaly "empty pattern list" - | [subst,patt] -> - (patvars,bind_aliases patvars subst patt,patt) - | _ -> anomaly "undetected disjunctive pattern" - -let rec match_args dest names constr = function - [] -> [],names,substl names constr - | _::q -> - let (name,typ,body)=dest constr in - let st={st_label=name;st_it=substl names typ} in - let qnames= - match name with - Anonymous -> assert false - | Name id -> mkVar id :: names in - let args,bnames,body = match_args dest qnames body q in - st::args,bnames,body - -let rec match_aliases names constr = function - [] -> [],names,substl names constr - | _::q -> - let (name,c,typ,body)=destLetIn constr in - let st={st_label=name;st_it=(substl names c,substl names typ)} in - let qnames= - match name with - Anonymous -> assert false - | Name id -> mkVar id :: names in - let args,bnames,body = match_aliases qnames body q in - st::args,bnames,body - -let detype_ground c = Detyping.detype false [] [] c - -let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = - let et,pinfo = - match info.pm_stack with - Per(et,pi,_,_)::_ -> et,pi - | _ -> error "No proof per cases/induction/inversion in progress." in - let mib,oib=Global.lookup_inductive pinfo.per_ind in - let num_params = pinfo.per_nparams in - let _ = - let expected = mib.Declarations.mind_nparams - num_params in - if List.length params <> expected then - errorlabstrm "suppose it is" - (str "Wrong number of extra arguments: " ++ - (if expected = 0 then str "none" else int expected) ++ spc () ++ - str "expected.") in - let app_ind = - let rind = RRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in - let rparams = List.map detype_ground pinfo.per_params in - let rparams_rec = - List.map - (fun (loc,(id,_)) -> - RVar (loc,id)) params in - let dum_args= - list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false))) - oib.Declarations.mind_nrealargs in - raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in - let pat_vars,aliases,patt = interp_pattern env pat in - let inject = function - Thesis (Plain) -> Rawterm.RSort(dummy_loc,RProp Null) - | Thesis (For rec_occ) -> - if not (List.mem rec_occ pat_vars) then - errorlabstrm "suppose it is" - (str "Variable " ++ Nameops.pr_id rec_occ ++ - str " does not occur in pattern."); - Rawterm.RSort(dummy_loc,RProp Null) - | This (c,_) -> c in - let term1 = rawconstr_of_hyps inject hyps raw_prop in - let loc_ids,npatt = - let rids=ref ([],pat_vars) in - let npatt= deanonymize rids patt in - List.rev (fst !rids),npatt in - let term2 = - RLetIn(dummy_loc,Anonymous, - RCast(dummy_loc,raw_of_pat npatt, - CastConv (DEFAULTcast,app_ind)),term1) in - let term3=List.fold_right let_in_one_alias aliases term2 in - let term4=List.fold_right prod_one_id loc_ids term3 in - let term5=List.fold_right prod_one_hyp params term4 in - let constr = understand sigma env term5 in - let tparams,nam4,rest4 = match_args destProd [] constr params in - let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in - let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in - let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in - let blend st st' = - match st'.st_it with - Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} - | This _ -> {st_it = This st.st_it;st_label=st.st_label} in - let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in - tparams,{pat_vars=tpatvars; - pat_aliases=taliases; - pat_constr=pat_pat; - pat_typ=pat_typ; - pat_pat=patt; - pat_expr=pat},thyps - -let interp_cut interp_it sigma env cut= - let nenv,nstat = interp_it sigma env cut.cut_stat in - {cut with - cut_stat=nstat; - cut_by=interp_justification_items sigma nenv cut.cut_by} - -let interp_no_bind interp_it sigma env x = - env,interp_it sigma env x - -let interp_suffices_clause sigma env (hyps,cot)= - let (locvars,_) as res = - match cot with - This (c,_) -> - let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in - nhyps,This nc - | Thesis Plain as th -> interp_hyps sigma env hyps,th - | Thesis (For n) -> error "\"thesis for\" is not applicable here." in - let push_one hyp env0 = - match hyp with - (Hprop st | Hvar st) -> - match st.st_label with - Name id -> Environ.push_named (id,None,st.st_it) env0 - | _ -> env in - let nenv = List.fold_right push_one locvars env in - nenv,res - -let interp_casee sigma env = function - Real c -> Real (understand sigma env (fst c)) - | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) - -let abstract_one_arg = function - (loc,(id,None)) -> - (fun raw -> - RLambda (dummy_loc,Name id, Explicit, - RHole (loc,Evd.BinderType (Name id)), raw)) - | (loc,(id,Some typ)) -> - (fun raw -> - RLambda (dummy_loc,Name id, Explicit, fst typ, raw)) - -let rawconstr_of_fun args body = - List.fold_right abstract_one_arg args (fst body) - -let interp_fun sigma env args body = - let constr=understand sigma env (rawconstr_of_fun args body) in - match_args destLambda [] constr args - -let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function - Pthus i -> Pthus (interp_bare_proof_instr info sigma env i) - | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i) - | Phence i -> Phence (interp_bare_proof_instr info sigma env i) - | Pcut c -> Pcut (interp_cut - (interp_no_bind (interp_statement - (interp_constr_or_thesis true))) - sigma env c) - | Psuffices c -> - Psuffices (interp_cut interp_suffices_clause sigma env c) - | Prew (s,c) -> Prew (s,interp_cut - (interp_no_bind (interp_statement - (interp_constr_in_type (get_eq_typ info env)))) - sigma env c) - - | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps) - | Pcase (params,pat,hyps) -> - let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in - Pcase (tparams,tpat,thyps) - | Ptake witl -> - Ptake (List.map (fun c -> understand sigma env (fst c)) witl) - | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c, - interp_hyps sigma env hyps) - | Pper (et,c) -> Pper (et,interp_casee sigma env c) - | Pend bt -> Pend bt - | Pescape -> Pescape - | Passume hyps -> Passume (interp_hyps sigma env hyps) - | Pgiven hyps -> Pgiven (interp_hyps sigma env hyps) - | Plet hyps -> Plet (interp_hyps sigma env hyps) - | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st) - | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st) - | Pdefine (id,args,body) -> - let nargs,_,nbody = interp_fun sigma env args body in - Pdefine (id,nargs,nbody) - | Pcast (id,typ) -> - Pcast(id,interp_constr true sigma env typ) - -let rec interp_proof_instr info sigma env instr= - {emph = instr.emph; - instr = interp_bare_proof_instr info sigma env instr.instr} - - - diff --git a/tactics/decl_interp.mli b/tactics/decl_interp.mli deleted file mode 100644 index e2c1e531..00000000 --- a/tactics/decl_interp.mli +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_proof_instr -> glob_proof_instr -val interp_proof_instr : Decl_mode.pm_info -> - Evd.evar_map -> Environ.env -> glob_proof_instr -> proof_instr diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml deleted file mode 100644 index 5a89e859..00000000 --- a/tactics/decl_proof_instr.ml +++ /dev/null @@ -1,1518 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (!strictness)),(fun b -> strictness:=b) - -let _ = - declare_bool_option - { optsync = true; - optname = "strict mode"; - optkey = ["Strict";"Proofs"]; - optread = get_strictness; - optwrite = set_strictness } - -let tcl_change_info_gen info_gen = - (fun gls -> - let gl =sig_it gls in - {it=[{gl with evar_extra=info_gen}];sigma=sig_sig gls}, - function - [pftree] -> - {pftree with - goal=gl; - ref=Some (Prim Change_evars,[pftree])} - | _ -> anomaly "change_info : Wrong number of subtrees") - -let tcl_change_info info gls = tcl_change_info_gen (Some (pm_in info)) gls - -let tcl_erase_info gls = tcl_change_info_gen None gls - -let special_whd gl= - let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in - (fun t -> Closure.whd_val infos (Closure.inject t)) - -let special_nf gl= - let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in - (fun t -> Closure.norm_val infos (Closure.inject t)) - -let is_good_inductive env ind = - let mib,oib = Inductive.lookup_mind_specif env ind in - oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib)) - -let check_not_per pts = - if not (Proof_trees.is_complete_proof (proof_of_pftreestate pts)) then - match get_stack pts with - Per (_,_,_,_)::_ -> - error "You are inside a proof per cases/induction.\n\ -Please \"suppose\" something or \"end\" it now." - | _ -> () - -let mk_evd metalist gls = - let evd0= create_goal_evar_defs (sig_sig gls) in - let add_one (meta,typ) evd = - meta_declare meta typ evd in - List.fold_right add_one metalist evd0 - -let is_tmp id = (string_of_id id).[0] = '_' - -let tmp_ids gls = - let ctx = pf_hyps gls in - match ctx with - [] -> [] - | _::q -> List.filter is_tmp (ids_of_named_context q) - -let clean_tmp gls = - let clean_id id0 gls0 = - tclTRY (clear [id0]) gls0 in - let rec clean_all = function - [] -> tclIDTAC - | id :: rest -> tclTHEN (clean_id id) (clean_all rest) - in - clean_all (tmp_ids gls) gls - -let assert_postpone id t = - assert_tac (Name id) t - -(* start a proof *) - -let start_proof_tac gls= - let gl=sig_it gls in - let info={pm_stack=[]} in - {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls}, - function - [pftree] -> - {pftree with - goal=gl; - ref=Some (Decl_proof true,[pftree])} - | _ -> anomaly "Dem : Wrong number of subtrees" - -let go_to_proof_mode () = - Pfedit.mutate - (fun pts -> nth_unproven 1 (solve_pftreestate start_proof_tac pts)) - -(* closing gaps *) - -let daimon_tac gls = - set_daimon_flag (); - ({it=[];sigma=sig_sig gls}, - function - [] -> - {open_subgoals=0; - goal=sig_it gls; - ref=Some (Daimon,[])} - | _ -> anomaly "Daimon: Wrong number of subtrees") - -let daimon _ pftree = - set_daimon_flag (); - {pftree with - open_subgoals=0; - ref=Some (Daimon,[])} - -let daimon_subtree = map_pftreestate (fun _ -> frontier_mapi daimon ) - -(* marking closed blocks *) - -let rec is_focussing_instr = function - Pthus i | Pthen i | Phence i -> is_focussing_instr i - | Pescape | Pper _ | Pclaim _ | Pfocus _ - | Psuppose _ | Pcase (_,_,_) -> true - | _ -> false - -let mark_rule_as_done = function - Decl_proof true -> Decl_proof false - | Decl_proof false -> - anomaly "already marked as done" - | Nested(Proof_instr (lock_focus,instr),spfl) -> - if lock_focus then - Nested(Proof_instr (false,instr),spfl) - else - anomaly "already marked as done" - | _ -> anomaly "mark_rule_as_done" - -let mark_proof_tree_as_done pt = - match pt.ref with - None -> anomaly "mark_proof_tree_as_done" - | Some (r,spfl) -> - {pt with ref= Some (mark_rule_as_done r,spfl)} - -let mark_as_done pts = - map_pftreestate - (fun _ -> mark_proof_tree_as_done) - (up_to_matching_rule is_focussing_command pts) - -(* post-instruction focus management *) - -let goto_current_focus pts = up_until_matching_rule is_focussing_command pts - -let goto_current_focus_or_top pts = - try - up_until_matching_rule is_focussing_command pts - with Not_found -> top_of_tree pts - -(* return *) - -let close_tactic_mode pts = - let pts1= - try goto_current_focus pts - with Not_found -> - error "\"return\" cannot be used outside of Declarative Proof Mode." in - let pts2 = daimon_subtree pts1 in - let pts3 = mark_as_done pts2 in - goto_current_focus pts3 - -let return_from_tactic_mode () = Pfedit.mutate close_tactic_mode - -(* end proof/claim *) - -let close_block bt pts = - let stack = - if Proof_trees.is_complete_proof (proof_of_pftreestate pts) then - get_top_stack pts - else - get_stack pts in - match bt,stack with - B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> - daimon_subtree (goto_current_focus pts) - | _, Claim::_ -> - error "\"end claim\" expected." - | _, Focus_claim::_ -> - error "\"end focus\" expected." - | _, [] -> - error "\"end proof\" expected." - | _, (Per (et,_,_,_)::_|Suppose_case::Per (et,_,_,_)::_) -> - begin - match et with - ET_Case_analysis -> error "\"end cases\" expected." - | ET_Induction -> error "\"end induction\" expected." - end - | _,_ -> anomaly "Lonely suppose on stack." - -(* utility for suppose / suppose it is *) - -let close_previous_case pts = - if - Proof_trees.is_complete_proof (proof_of_pftreestate pts) - then - match get_top_stack pts with - Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..." - | Suppose_case :: Per (et,_,_,_) :: _ -> - goto_current_focus (mark_as_done pts) - | _ -> error "Not inside a proof per cases or induction." - else - match get_stack pts with - Per (et,_,_,_) :: _ -> pts - | Suppose_case :: Per (et,_,_,_) :: _ -> - goto_current_focus (mark_as_done (daimon_subtree pts)) - | _ -> error "Not inside a proof per cases or induction." - -(* Proof instructions *) - -(* automation *) - -let filter_hyps f gls = - let filter_aux (id,_,_) = - if f id then - tclIDTAC - else - tclTRY (clear [id]) in - tclMAP filter_aux (Environ.named_context_of_val gls.it.evar_hyps) gls - -let local_hyp_prefix = id_of_string "___" - -let add_justification_hyps keep items gls = - let add_aux c gls= - match kind_of_term c with - Var id -> - keep:=Idset.add id !keep; - tclIDTAC gls - | _ -> - let id=pf_get_new_id local_hyp_prefix gls in - keep:=Idset.add id !keep; - tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere) - (thin_body [id]) gls in - tclMAP add_aux items gls - -let prepare_goal items gls = - let tokeep = ref Idset.empty in - let auxres = add_justification_hyps tokeep items gls in - tclTHENLIST - [ (fun _ -> auxres); - filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls - -let my_automation_tac = ref - (fun gls -> anomaly "No automation registered") - -let register_automation_tac tac = my_automation_tac:= tac - -let automation_tac gls = !my_automation_tac gls - -let justification tac gls= - tclORELSE - (tclSOLVE [tclTHEN tac assumption]) - (fun gls -> - if get_strictness () then - error "Insufficient justification." - else - begin - msg_warning (str "Insufficient justification."); - daimon_tac gls - end) gls - -let default_justification elems gls= - justification (tclTHEN (prepare_goal elems) automation_tac) gls - -(* code for conclusion refining *) - -let constant dir s = lazy (Coqlib.gen_constant "Declarative" dir s) - -let _and = constant ["Init";"Logic"] "and" - -let _and_rect = constant ["Init";"Logic"] "and_rect" - -let _prod = constant ["Init";"Datatypes"] "prod" - -let _prod_rect = constant ["Init";"Datatypes"] "prod_rect" - -let _ex = constant ["Init";"Logic"] "ex" - -let _ex_ind = constant ["Init";"Logic"] "ex_ind" - -let _sig = constant ["Init";"Specif"] "sig" - -let _sig_rect = constant ["Init";"Specif"] "sig_rect" - -let _sigT = constant ["Init";"Specif"] "sigT" - -let _sigT_rect = constant ["Init";"Specif"] "sigT_rect" - -type stackd_elt = -{se_meta:metavariable; - se_type:types; - se_last_meta:metavariable; - se_meta_list:(metavariable*types) list; - se_evd: evar_map} - -let rec replace_in_list m l = function - [] -> raise Not_found - | c::q -> if m=fst c then l@q else c::replace_in_list m l q - -let enstack_subsubgoals env se stack gls= - let hd,params = decompose_app (special_whd gls se.se_type) in - match kind_of_term hd with - Ind ind when is_good_inductive env ind -> - let mib,oib= - Inductive.lookup_mind_specif env ind in - let gentypes= - Inductive.arities_of_constructors ind (mib,oib) in - let process i gentyp = - let constructor = mkConstruct(ind,succ i) - (* constructors numbering*) in - let appterm = applist (constructor,params) in - let apptype = Term.prod_applist gentyp params in - let rc,_ = Reduction.dest_prod env apptype in - let rec meta_aux last lenv = function - [] -> (last,lenv,[]) - | (nam,_,typ)::q -> - let nlast=succ last in - let (llast,holes,metas) = - meta_aux nlast (mkMeta nlast :: lenv) q in - (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in - let (nlast,holes,nmetas) = - meta_aux se.se_last_meta [] (List.rev rc) in - let refiner = applist (appterm,List.rev holes) in - let evd = meta_assign se.se_meta - (refiner,(ConvUpToEta 0,TypeProcessed (* ? *))) se.se_evd in - let ncreated = replace_in_list - se.se_meta nmetas se.se_meta_list in - let evd0 = List.fold_left - (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in - List.iter (fun (m,typ) -> - Stack.push - {se_meta=m; - se_type=typ; - se_evd=evd0; - se_meta_list=ncreated; - se_last_meta=nlast} stack) (List.rev nmetas) - in - Array.iteri process gentypes - | _ -> () - -let rec nf_list evd = - function - [] -> [] - | (m,typ)::others -> - if meta_defined evd m then - nf_list evd others - else - (m,nf_meta evd typ)::nf_list evd others - -let find_subsubgoal c ctyp skip submetas gls = - let env= pf_env gls in - let concl = pf_concl gls in - let evd = mk_evd ((0,concl)::submetas) gls in - let stack = Stack.create () in - let max_meta = - List.fold_left (fun a (m,_) -> max a m) 0 submetas in - let _ = Stack.push - {se_meta=0; - se_type=concl; - se_last_meta=max_meta; - se_meta_list=[0,concl]; - se_evd=evd} stack in - let rec dfs n = - let se = Stack.pop stack in - try - let unifier = - Unification.w_unify true env Reduction.CUMUL - ctyp se.se_type se.se_evd in - if n <= 0 then - {se with - se_evd=meta_assign se.se_meta - (c,(ConvUpToEta 0,TypeNotProcessed (* ?? *))) unifier; - se_meta_list=replace_in_list - se.se_meta submetas se.se_meta_list} - else - dfs (pred n) - with _ -> - begin - enstack_subsubgoals env se stack gls; - dfs n - end in - let nse= try dfs skip with Stack.Empty -> raise Not_found in - nf_list nse.se_evd nse.se_meta_list,nf_meta nse.se_evd (mkMeta 0) - -let concl_refiner metas body gls = - let concl = pf_concl gls in - let evd = sig_sig gls in - let env = pf_env gls in - let sort = family_of_sort (Typing.sort_of env evd concl) in - let rec aux env avoid subst = function - [] -> anomaly "concl_refiner: cannot happen" - | (n,typ)::rest -> - let _A = subst_meta subst typ in - let x = id_of_name_using_hdchar env _A Anonymous in - let _x = fresh_id avoid x gls in - let nenv = Environ.push_named (_x,None,_A) env in - let asort = family_of_sort (Typing.sort_of nenv evd _A) in - let nsubst = (n,mkVar _x)::subst in - if rest = [] then - asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) - else - let bsort,_B,nbody = - aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in - let body = mkNamedLambda _x _A nbody in - if occur_term (mkVar _x) _B then - begin - let _P = mkNamedLambda _x _A _B in - match bsort,sort with - InProp,InProp -> - let _AxB = mkApp(Lazy.force _ex,[|_A;_P|]) in - InProp,_AxB, - mkApp(Lazy.force _ex_ind,[|_A;_P;concl;body|]) - | InProp,_ -> - let _AxB = mkApp(Lazy.force _sig,[|_A;_P|]) in - let _P0 = mkLambda(Anonymous,_AxB,concl) in - InType,_AxB, - mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|]) - | _,_ -> - let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in - let _P0 = mkLambda(Anonymous,_AxB,concl) in - InType,_AxB, - mkApp(Lazy.force _sigT_rect,[|_A;_P;_P0;body|]) - end - else - begin - match asort,bsort with - InProp,InProp -> - let _AxB = mkApp(Lazy.force _and,[|_A;_B|]) in - InProp,_AxB, - mkApp(Lazy.force _and_rect,[|_A;_B;concl;body|]) - |_,_ -> - let _AxB = mkApp(Lazy.force _prod,[|_A;_B|]) in - let _P0 = mkLambda(Anonymous,_AxB,concl) in - InType,_AxB, - mkApp(Lazy.force _prod_rect,[|_A;_B;_P0;body|]) - end - in - let (_,_,prf) = aux env [] [] metas in - mkApp(prf,[|mkMeta 1|]) - -let thus_tac c ctyp submetas gls = - let list,proof = - try - find_subsubgoal c ctyp 0 submetas gls - with Not_found -> - error "I could not relate this statement to the thesis." in - if list = [] then - exact_check proof gls - else - let refiner = concl_refiner list proof gls in - Tactics.refine refiner gls - -(* general forward step *) - -let mk_stat_or_thesis info gls = function - This c -> c - | Thesis (For _ ) -> - error "\"thesis for ...\" is not applicable here." - | Thesis Plain -> pf_concl gls - -let just_tac _then cut info gls0 = - let items_tac gls = - match cut.cut_by with - None -> tclIDTAC gls - | Some items -> - let items_ = - if _then then - let last_id = get_last (pf_env gls) in - (mkVar last_id)::items - else items - in prepare_goal items_ gls in - let method_tac gls = - match cut.cut_using with - None -> - automation_tac gls - | Some tac -> - (Tacinterp.eval_tactic tac) gls in - justification (tclTHEN items_tac method_tac) gls0 - -let instr_cut mkstat _thus _then cut gls0 = - let info = get_its_info gls0 in - let stat = cut.cut_stat in - let (c_id,_) = match stat.st_label with - Anonymous -> - pf_get_new_id (id_of_string "_fact") gls0,false - | Name id -> id,true in - let c_stat = mkstat info gls0 stat.st_it in - let thus_tac gls= - if _thus then - thus_tac (mkVar c_id) c_stat [] gls - else tclIDTAC gls in - tclTHENS (assert_postpone c_id c_stat) - [tclTHEN tcl_erase_info (just_tac _then cut info); - thus_tac] gls0 - - - -(* iterated equality *) -let _eq = Libnames.constr_of_global (Coqlib.glob_eq) - -let decompose_eq id gls = - let typ = pf_get_hyp_typ gls id in - let whd = (special_whd gls typ) in - match kind_of_term whd with - App (f,args)-> - if eq_constr f _eq && (Array.length args)=3 - then (args.(0), - args.(1), - args.(2)) - else error "Previous step is not an equality." - | _ -> error "Previous step is not an equality." - -let instr_rew _thus rew_side cut gls0 = - let last_id = - try get_last (pf_env gls0) with _ -> error "No previous equality." in - let typ,lhs,rhs = decompose_eq last_id gls0 in - let items_tac gls = - match cut.cut_by with - None -> tclIDTAC gls - | Some items -> prepare_goal items gls in - let method_tac gls = - match cut.cut_using with - None -> - automation_tac gls - | Some tac -> - (Tacinterp.eval_tactic tac) gls in - let just_tac gls = - justification (tclTHEN items_tac method_tac) gls in - let (c_id,_) = match cut.cut_stat.st_label with - Anonymous -> - pf_get_new_id (id_of_string "_eq") gls0,false - | Name id -> id,true in - let thus_tac new_eq gls= - if _thus then - thus_tac (mkVar c_id) new_eq [] gls - else tclIDTAC gls in - match rew_side with - Lhs -> - let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in - tclTHENS (assert_postpone c_id new_eq) - [tclTHEN tcl_erase_info - (tclTHENS (transitivity lhs) - [just_tac;exact_check (mkVar last_id)]); - thus_tac new_eq] gls0 - | Rhs -> - let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in - tclTHENS (assert_postpone c_id new_eq) - [tclTHEN tcl_erase_info - (tclTHENS (transitivity rhs) - [exact_check (mkVar last_id);just_tac]); - thus_tac new_eq] gls0 - - - -(* tactics for claim/focus *) - -let instr_claim _thus st gls0 = - let info = get_its_info gls0 in - let (id,_) = match st.st_label with - Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false - | Name id -> id,true in - let thus_tac gls= - if _thus then - thus_tac (mkVar id) st.st_it [] gls - else tclIDTAC gls in - let ninfo1 = {pm_stack= - (if _thus then Focus_claim else Claim)::info.pm_stack} in - tclTHENS (assert_postpone id st.st_it) - [tcl_change_info ninfo1; - thus_tac] gls0 - -(* tactics for assume *) - -let push_intro_tac coerce nam gls = - let (hid,_) = - match nam with - Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false - | Name id -> id,true in - tclTHENLIST - [intro_mustbe_force hid; - coerce hid] - gls - -let assume_tac hyps gls = - List.fold_right - (fun (Hvar st | Hprop st) -> - tclTHEN - (push_intro_tac - (fun id -> - convert_hyp (id,None,st.st_it)) st.st_label)) - hyps tclIDTAC gls - -let assume_hyps_or_theses hyps gls = - List.fold_right - (function - (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> - tclTHEN - (push_intro_tac - (fun id -> - convert_hyp (id,None,c)) nam) - | Hprop {st_label=nam;st_it=Thesis (tk)} -> - tclTHEN - (push_intro_tac - (fun id -> tclIDTAC) nam)) - hyps tclIDTAC gls - -let assume_st hyps gls = - List.fold_right - (fun st -> - tclTHEN - (push_intro_tac - (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) - hyps tclIDTAC gls - -let assume_st_letin hyps gls = - List.fold_right - (fun st -> - tclTHEN - (push_intro_tac - (fun id -> - convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label)) - hyps tclIDTAC gls - -(* suffices *) - -let rec metas_from n hyps = - match hyps with - _ :: q -> n :: metas_from (succ n) q - | [] -> [] - -let rec build_product args body = - match args with - (Hprop st| Hvar st )::rest -> - let pprod= lift 1 (build_product rest body) in - let lbody = - match st.st_label with - Anonymous -> pprod - | Name id -> subst_term (mkVar id) pprod in - mkProd (st.st_label, st.st_it, lbody) - | [] -> body - -let rec build_applist prod = function - [] -> [],prod - | n::q -> - let (_,typ,_) = destProd prod in - let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in - (n,typ)::ctx,head - -let instr_suffices _then cut gls0 = - let info = get_its_info gls0 in - let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in - let ctx,hd = cut.cut_stat in - let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in - let metas = metas_from 1 ctx in - let c_ctx,c_head = build_applist c_stat metas in - let c_term = applist (mkVar c_id,List.map mkMeta metas) in - let thus_tac gls= - thus_tac c_term c_head c_ctx gls in - tclTHENS (assert_postpone c_id c_stat) - [tclTHENLIST - [ assume_tac ctx; - tcl_erase_info; - just_tac _then cut info]; - thus_tac] gls0 - -(* tactics for consider/given *) - -let conjunction_arity id gls = - let typ = pf_get_hyp_typ gls id in - let hd,params = decompose_app (special_whd gls typ) in - let env =pf_env gls in - match kind_of_term hd with - Ind ind when is_good_inductive env ind -> - let mib,oib= - Inductive.lookup_mind_specif env ind in - let gentypes= - Inductive.arities_of_constructors ind (mib,oib) in - let _ = if Array.length gentypes <> 1 then raise Not_found in - let apptype = Term.prod_applist gentypes.(0) params in - let rc,_ = Reduction.dest_prod env apptype in - List.length rc - | _ -> raise Not_found - -let rec intron_then n ids ltac gls = - if n<=0 then - ltac ids gls - else - let id = pf_get_new_id (id_of_string "_tmp") gls in - tclTHEN - (intro_mustbe_force id) - (intron_then (pred n) (id::ids) ltac) gls - - -let rec consider_match may_intro introduced available expected gls = - match available,expected with - [],[] -> - tclIDTAC gls - | _,[] -> error "Last statements do not match a complete hypothesis." - (* should tell which ones *) - | [],hyps -> - if may_intro then - begin - let id = pf_get_new_id (id_of_string "_tmp") gls in - tclIFTHENELSE - (intro_mustbe_force id) - (consider_match true [] [id] hyps) - (fun _ -> - error "Not enough sub-hypotheses to match statements.") - gls - end - else - error "Not enough sub-hypotheses to match statements." - (* should tell which ones *) - | id::rest_ids,(Hvar st | Hprop st)::rest -> - tclIFTHENELSE (convert_hyp (id,None,st.st_it)) - begin - match st.st_label with - Anonymous -> - consider_match may_intro ((id,false)::introduced) rest_ids rest - | Name hid -> - tclTHENLIST - [rename_hyp [id,hid]; - consider_match may_intro ((hid,true)::introduced) rest_ids rest] - end - begin - (fun gls -> - let nhyps = - try conjunction_arity id gls with - Not_found -> error "Matching hypothesis not found." in - tclTHENLIST - [general_case_analysis false (mkVar id,NoBindings); - intron_then nhyps [] - (fun l -> consider_match may_intro introduced - (List.rev_append l rest_ids) expected)] gls) - end - gls - -let consider_tac c hyps gls = - match kind_of_term (strip_outer_cast c) with - Var id -> - consider_match false [] [id] hyps gls - | _ -> - let id = pf_get_new_id (id_of_string "_tmp") gls in - tclTHEN - (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c) - (consider_match false [] [id] hyps) gls - - -let given_tac hyps gls = - consider_match true [] [] hyps gls - -(* tactics for take *) - -let rec take_tac wits gls = - match wits with - [] -> tclIDTAC gls - | wit::rest -> - let typ = pf_type_of gls wit in - tclTHEN (thus_tac wit typ []) (take_tac rest) gls - - -(* tactics for define *) - -let rec build_function args body = - match args with - st::rest -> - let pfun= lift 1 (build_function rest body) in - let id = match st.st_label with - Anonymous -> assert false - | Name id -> id in - mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun) - | [] -> body - -let define_tac id args body gls = - let t = build_function args body in - letin_tac None (Name id) t None Tacexpr.nowhere gls - -(* tactics for reconsider *) - -let cast_tac id_or_thesis typ gls = - match id_or_thesis with - This id -> - let (_,body,_) = pf_get_hyp gls id in - convert_hyp (id,body,typ) gls - | Thesis (For _ ) -> - error "\"thesis for ...\" is not applicable here." - | Thesis Plain -> - convert_concl typ DEFAULTcast gls - -(* per cases *) - -let is_rec_pos (main_ind,wft) = - match main_ind with - None -> false - | Some index -> - match fst (Rtree.dest_node wft) with - Mrec i when i = index -> true - | _ -> false - -let rec constr_trees (main_ind,wft) ind = - match Rtree.dest_node wft with - Norec,_ -> - let itree = - (snd (Global.lookup_inductive ind)).mind_recargs in - constr_trees (None,itree) ind - | _,constrs -> main_ind,constrs - -let ind_args rp ind = - let main_ind,constrs = constr_trees rp ind in - let args ctree = - Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in - Array.map args constrs - -let init_tree ids ind rp nexti = - let indargs = ind_args rp ind in - let do_i i arp = (Array.map is_rec_pos arp),nexti i arp in - Split_patt (ids,ind,Array.mapi do_i indargs) - -let map_tree_rp rp id_fun mapi = function - Split_patt (ids,ind,branches) -> - let indargs = ind_args rp ind in - let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in - Split_patt (id_fun ids,ind,Array.mapi do_i branches) - | _ -> failwith "map_tree_rp: not a splitting node" - -let map_tree id_fun mapi = function - Split_patt (ids,ind,branches) -> - let do_i i (recargs,bri) = recargs,mapi i bri in - Split_patt (id_fun ids,ind,Array.mapi do_i branches) - | _ -> failwith "map_tree: not a splitting node" - - -let start_tree env ind rp = - init_tree Idset.empty ind rp (fun _ _ -> None) - -let build_per_info etype casee gls = - let concl=pf_concl gls in - let env=pf_env gls in - let ctyp=pf_type_of gls casee in - let is_dep = dependent casee concl in - let hd,args = decompose_app (special_whd gls ctyp) in - let ind = - try - destInd hd - with _ -> - error "Case analysis must be done on an inductive object." in - let mind,oind = Global.lookup_inductive ind in - let nparams,index = - match etype with - ET_Induction -> mind.mind_nparams_rec,Some (snd ind) - | _ -> mind.mind_nparams,None in - let params,real_args = list_chop nparams args in - let abstract_obj c body = - let typ=pf_type_of gls c in - lambda_create env (typ,subst_term c body) in - let pred= List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term casee concl)) in - is_dep, - {per_casee=casee; - per_ctype=ctyp; - per_ind=ind; - per_pred=pred; - per_args=real_args; - per_params=params; - per_nparams=nparams; - per_wf=index,oind.mind_recargs} - -let per_tac etype casee gls= - let env=pf_env gls in - let info = get_its_info gls in - match casee with - Real c -> - let is_dep,per_info = build_per_info etype c gls in - let ek = - if is_dep then - EK_dep (start_tree env per_info.per_ind per_info.per_wf) - else EK_unknown in - tcl_change_info - {pm_stack= - Per(etype,per_info,ek,[])::info.pm_stack} gls - | Virtual cut -> - assert (cut.cut_stat.st_label=Anonymous); - let id = pf_get_new_id (id_of_string "anonymous_matched") gls in - let c = mkVar id in - let modified_cut = - {cut with cut_stat={cut.cut_stat with st_label=Name id}} in - tclTHEN - (instr_cut (fun _ _ c -> c) false false modified_cut) - (fun gls0 -> - let is_dep,per_info = build_per_info etype c gls0 in - assert (not is_dep); - tcl_change_info - {pm_stack= - Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0) - gls - -(* suppose *) - -let register_nodep_subcase id= function - Per(et,pi,ek,clauses)::s -> - begin - match ek with - EK_unknown -> clauses,Per(et,pi,EK_nodep,id::clauses)::s - | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s - | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"." - end - | _ -> anomaly "wrong stack state" - -let suppose_tac hyps gls0 = - let info = get_its_info gls0 in - let thesis = pf_concl gls0 in - let id = pf_get_new_id (id_of_string "subcase_") gls0 in - let clause = build_product hyps thesis in - let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in - let old_clauses,stack = register_nodep_subcase id info.pm_stack in - let ninfo2 = {pm_stack=stack} in - tclTHENS (assert_postpone id clause) - [tclTHENLIST [tcl_change_info ninfo1; - assume_tac hyps; - clear old_clauses]; - tcl_change_info ninfo2] gls0 - -(* suppose it is ... *) - -(* pattern matching compiling *) - -let rec skip_args rest ids n = - if n <= 0 then - Close_patt rest - else - Skip_patt (ids,skip_args rest ids (pred n)) - -let rec tree_of_pats ((id,_) as cpl) pats = - match pats with - [] -> End_patt cpl - | args::stack -> - match args with - [] -> Close_patt (tree_of_pats cpl stack) - | (patt,rp) :: rest_args -> - match patt with - PatVar (_,v) -> - Skip_patt (Idset.singleton id, - tree_of_pats cpl (rest_args::stack)) - | PatCstr (_,(ind,cnum),args,nam) -> - let nexti i ati = - if i = pred cnum then - let nargs = - list_map_i (fun j a -> (a,ati.(j))) 0 args in - Some (Idset.singleton id, - tree_of_pats cpl (nargs::rest_args::stack)) - else None - in init_tree Idset.empty ind rp nexti - -let rec add_branch ((id,_) as cpl) pats tree= - match pats with - [] -> - begin - match tree with - End_patt cpl0 -> End_patt cpl0 - (* this ensures precedence for overlapping patterns *) - | _ -> anomaly "tree is expected to end here" - end - | args::stack -> - match args with - [] -> - begin - match tree with - Close_patt t -> - Close_patt (add_branch cpl stack t) - | _ -> anomaly "we should pop here" - end - | (patt,rp) :: rest_args -> - match patt with - PatVar (_,v) -> - begin - match tree with - Skip_patt (ids,t) -> - Skip_patt (Idset.add id ids, - add_branch cpl (rest_args::stack) t) - | Split_patt (_,_,_) -> - map_tree (Idset.add id) - (fun i bri -> - append_branch cpl 1 (rest_args::stack) bri) - tree - | _ -> anomaly "No pop/stop expected here" - end - | PatCstr (_,(ind,cnum),args,nam) -> - match tree with - Skip_patt (ids,t) -> - let nexti i ati = - if i = pred cnum then - let nargs = - list_map_i (fun j a -> (a,ati.(j))) 0 args in - Some (Idset.add id ids, - add_branch cpl (nargs::rest_args::stack) - (skip_args t ids (Array.length ati))) - else - Some (ids, - skip_args t ids (Array.length ati)) - in init_tree ids ind rp nexti - | Split_patt (_,ind0,_) -> - if (ind <> ind0) then error - (* this can happen with coercions *) - "Case pattern belongs to wrong inductive type."; - let mapi i ati bri = - if i = pred cnum then - let nargs = - list_map_i (fun j a -> (a,ati.(j))) 0 args in - append_branch cpl 0 - (nargs::rest_args::stack) bri - else bri in - map_tree_rp rp (fun ids -> ids) mapi tree - | _ -> anomaly "No pop/stop expected here" -and append_branch ((id,_) as cpl) depth pats = function - Some (ids,tree) -> - Some (Idset.add id ids,append_tree cpl depth pats tree) - | None -> - Some (Idset.singleton id,tree_of_pats cpl pats) -and append_tree ((id,_) as cpl) depth pats tree = - if depth<=0 then add_branch cpl pats tree - else match tree with - Close_patt t -> - Close_patt (append_tree cpl (pred depth) pats t) - | Skip_patt (ids,t) -> - Skip_patt (Idset.add id ids,append_tree cpl depth pats t) - | End_patt _ -> anomaly "Premature end of branch" - | Split_patt (_,_,_) -> - map_tree (Idset.add id) - (fun i bri -> append_branch cpl (succ depth) pats bri) tree - -(* suppose it is *) - -let rec st_assoc id = function - [] -> raise Not_found - | st::_ when st.st_label = id -> st.st_it - | _ :: rest -> st_assoc id rest - -let thesis_for obj typ per_info env= - let rc,hd1=decompose_prod typ in - let cind,all_args=decompose_app typ in - let ind = destInd cind in - let _ = if ind <> per_info.per_ind then - errorlabstrm "thesis_for" - ((Printer.pr_constr_env env obj) ++ spc () ++ - str"cannot give an induction hypothesis (wrong inductive type).") in - let params,args = list_chop per_info.per_nparams all_args in - let _ = if not (List.for_all2 eq_constr params per_info.per_params) then - errorlabstrm "thesis_for" - ((Printer.pr_constr_env env obj) ++ spc () ++ - str "cannot give an induction hypothesis (wrong parameters).") in - let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in - compose_prod rc (whd_beta Evd.empty hd2) - -let rec build_product_dep pat_info per_info args body gls = - match args with - (Hprop {st_label=nam;st_it=This c} - | Hvar {st_label=nam;st_it=c})::rest -> - let pprod= - lift 1 (build_product_dep pat_info per_info rest body gls) in - let lbody = - match nam with - Anonymous -> body - | Name id -> subst_var id pprod in - mkProd (nam,c,lbody) - | Hprop ({st_it=Thesis tk} as st)::rest -> - let pprod= - lift 1 (build_product_dep pat_info per_info rest body gls) in - let lbody = - match st.st_label with - Anonymous -> body - | Name id -> subst_var id pprod in - let ptyp = - match tk with - For id -> - let obj = mkVar id in - let typ = - try st_assoc (Name id) pat_info.pat_vars - with Not_found -> - snd (st_assoc (Name id) pat_info.pat_aliases) in - thesis_for obj typ per_info (pf_env gls) - | Plain -> pf_concl gls in - mkProd (st.st_label,ptyp,lbody) - | [] -> body - -let build_dep_clause params pat_info per_info hyps gls = - let concl= - thesis_for pat_info.pat_constr pat_info.pat_typ per_info (pf_env gls) in - let open_clause = - build_product_dep pat_info per_info hyps concl gls in - let prod_one st body = - match st.st_label with - Anonymous -> mkProd(Anonymous,st.st_it,lift 1 body) - | Name id -> mkNamedProd id st.st_it (lift 1 body) in - let let_one_in st body = - match st.st_label with - Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body) - | Name id -> - mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in - let aliased_clause = - List.fold_right let_one_in pat_info.pat_aliases open_clause in - List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause - -let rec register_dep_subcase id env per_info pat = function - EK_nodep -> error "Only \"suppose it is\" can be used here." - | EK_unknown -> - register_dep_subcase id env per_info pat - (EK_dep (start_tree env per_info.per_ind per_info.per_wf)) - | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree) - -let case_tac params pat_info hyps gls0 = - let info = get_its_info gls0 in - let id = pf_get_new_id (id_of_string "subcase_") gls0 in - let et,per_info,ek,old_clauses,rest = - match info.pm_stack with - Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) - | _ -> anomaly "wrong place for cases" in - let clause = build_dep_clause params pat_info per_info hyps gls0 in - let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in - let nek = - register_dep_subcase (id,(List.length params,List.length hyps)) - (pf_env gls0) per_info pat_info.pat_pat ek in - let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in - tclTHENS (assert_postpone id clause) - [tclTHENLIST - [tcl_change_info ninfo1; - assume_st (params@pat_info.pat_vars); - assume_st_letin pat_info.pat_aliases; - assume_hyps_or_theses hyps; - clear old_clauses]; - tcl_change_info ninfo2] gls0 - -(* end cases *) - -type instance_stack = - (constr option*(constr list) list) list - -let initial_instance_stack ids = - List.map (fun id -> id,[None,[]]) ids - -let push_one_arg arg = function - [] -> anomaly "impossible" - | (head,args) :: ctx -> - ((head,(arg::args)) :: ctx) - -let push_arg arg stacks = - List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks - - -let push_one_head c ids (id,stack) = - let head = if Idset.mem id ids then Some c else None in - id,(head,[]) :: stack - -let push_head c ids stacks = - List.map (push_one_head c ids) stacks - -let pop_one (id,stack) = - let nstack= - match stack with - [] -> anomaly "impossible" - | [c] as l -> l - | (Some head,args)::(head0,args0)::ctx -> - let arg = applist (head,(List.rev args)) in - (head0,(arg::args0))::ctx - | (None,args)::(head0,args0)::ctx -> - (head0,(args@args0))::ctx - in id,nstack - -let pop_stacks stacks = - List.map pop_one stacks - -let hrec_for fix_id per_info gls obj_id = - let obj=mkVar obj_id in - let typ=pf_get_hyp_typ gls obj_id in - let rc,hd1=decompose_prod typ in - let cind,all_args=decompose_app typ in - let ind = destInd cind in assert (ind=per_info.per_ind); - let params,args= list_chop per_info.per_nparams all_args in - assert begin - try List.for_all2 eq_constr params per_info.per_params with - Invalid_argument _ -> false end; - let hd2 = applist (mkVar fix_id,args@[obj]) in - compose_lam rc (whd_beta gls.sigma hd2) - - -let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = - match tree, objs with - Close_patt t,_ -> - let args0 = pop_stacks args in - execute_cases fix_name per_info tacnext args0 objs nhrec t gls - | Skip_patt (_,t),skipped::next_objs -> - let args0 = push_arg skipped args in - execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls - | End_patt (id,(nparams,nhyps)),[] -> - begin - match List.assoc id args with - [None,br_args] -> - let all_metas = - list_tabulate (fun n -> mkMeta (succ n)) (nparams + nhyps) in - let param_metas,hyp_metas = list_chop nparams all_metas in - tclTHEN - (tclDO nhrec introf) - (tacnext - (applist (mkVar id, - List.append param_metas - (List.rev_append br_args hyp_metas)))) gls - | _ -> anomaly "wrong stack size" - end - | Split_patt (ids,ind,br), casee::next_objs -> - let (mind,oind) as spec = Global.lookup_inductive ind in - let nparams = mind.mind_nparams in - let concl=pf_concl gls in - let env=pf_env gls in - let ctyp=pf_type_of gls casee in - let hd,all_args = decompose_app (special_whd gls ctyp) in - let _ = assert (destInd hd = ind) in (* just in case *) - let params,real_args = list_chop nparams all_args in - let abstract_obj c body = - let typ=pf_type_of gls c in - lambda_create env (typ,subst_term c body) in - let elim_pred = List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term casee concl)) in - let case_info = Inductiveops.make_case_info env ind RegularStyle in - let gen_arities = Inductive.arities_of_constructors ind spec in - let f_ids typ = - let sign = - (prod_assum (Term.prod_applist typ params)) in - find_intro_names sign gls in - let constr_args_ids = Array.map f_ids gen_arities in - let case_term = - mkCase(case_info,elim_pred,casee, - Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in - let branch_tac i (recargs,bro) gls0 = - let args_ids = constr_args_ids.(i) in - let rec aux n = function - [] -> - assert (n=Array.length recargs); - next_objs,[],nhrec - | id :: q -> - let objs,recs,nrec = aux (succ n) q in - if recargs.(n) - then (mkVar id::objs),(id::recs),succ nrec - else (mkVar id::objs),recs,nrec in - let objs,recs,nhrec = aux 0 args_ids in - tclTHENLIST - [tclMAP intro_mustbe_force args_ids; - begin - fun gls1 -> - let hrecs = - List.map - (fun id -> - hrec_for (out_name fix_name) per_info gls1 id) - recs in - generalize hrecs gls1 - end; - match bro with - None -> - msg_warning (str "missing case"); - tacnext (mkMeta 1) - | Some (sub_ids,tree) -> - let br_args = - List.filter - (fun (id,_) -> Idset.mem id sub_ids) args in - let construct = - applist (mkConstruct(ind,succ i),params) in - let p_args = - push_head construct ids br_args in - execute_cases fix_name per_info tacnext - p_args objs nhrec tree] gls0 in - tclTHENSV - (refine case_term) - (Array.mapi branch_tac br) gls - | Split_patt (_, _, _) , [] -> - anomaly "execute_cases : Nothing to split" - | Skip_patt _ , [] -> - anomaly "execute_cases : Nothing to skip" - | End_patt (_,_) , _ :: _ -> - anomaly "execute_cases : End of branch with garbage left" - -let understand_my_constr c gls = - let env = pf_env gls in - let nc = names_of_rel_context env in - let rawc = Detyping.detype false [] nc c in - let rec frob = function REvar _ -> RHole (dummy_loc,QuestionMark Expand) | rc -> map_rawconstr frob rc in - Pretyping.Default.understand_tcc (sig_sig gls) env ~expected_type:(pf_concl gls) (frob rawc) - -let set_refine,my_refine = -let refine = ref (fun (_:open_constr) -> (assert false : tactic) ) in -((fun tac -> refine:= tac), -(fun c gls -> - let oc = understand_my_constr c gls in - !refine oc gls)) - -(* end focus/claim *) - -let end_tac et2 gls = - let info = get_its_info gls in - let et1,pi,ek,clauses = - match info.pm_stack with - Suppose_case::_ -> - anomaly "This case should already be trapped" - | Claim::_ -> - error "\"end claim\" expected." - | Focus_claim::_ -> - error "\"end focus\" expected." - | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) - | [] -> - anomaly "This case should already be trapped" in - let et = - if et1 <> et2 then - match et1 with - ET_Case_analysis -> - error "\"end cases\" expected." - | ET_Induction -> - error "\"end induction\" expected." - else et1 in - tclTHEN - tcl_erase_info - begin - match et,ek with - _,EK_unknown -> - tclSOLVE [simplest_elim pi.per_casee] - | ET_Case_analysis,EK_nodep -> - tclTHEN - (general_case_analysis false (pi.per_casee,NoBindings)) - (default_justification (List.map mkVar clauses)) - | ET_Induction,EK_nodep -> - tclTHENLIST - [generalize (pi.per_args@[pi.per_casee]); - simple_induct (AnonHyp (succ (List.length pi.per_args))); - default_justification (List.map mkVar clauses)] - | ET_Case_analysis,EK_dep tree -> - execute_cases Anonymous pi - (fun c -> tclTHENLIST - [my_refine c; - clear clauses; - justification assumption]) - (initial_instance_stack clauses) [pi.per_casee] 0 tree - | ET_Induction,EK_dep tree -> - let nargs = (List.length pi.per_args) in - tclTHEN (generalize (pi.per_args@[pi.per_casee])) - begin - fun gls0 -> - let fix_id = - pf_get_new_id (id_of_string "_fix") gls0 in - let c_id = - pf_get_new_id (id_of_string "_main_arg") gls0 in - tclTHENLIST - [fix (Some fix_id) (succ nargs); - tclDO nargs introf; - intro_mustbe_force c_id; - execute_cases (Name fix_id) pi - (fun c -> - tclTHENLIST - [clear [fix_id]; - my_refine c; - clear clauses; - justification assumption]) - (initial_instance_stack clauses) - [mkVar c_id] 0 tree] gls0 - end - end gls - -(* escape *) - -let escape_tac gls = tcl_erase_info gls - -(* General instruction engine *) - -let rec do_proof_instr_gen _thus _then instr = - match instr with - Pthus i -> - assert (not _thus); - do_proof_instr_gen true _then i - | Pthen i -> - assert (not _then); - do_proof_instr_gen _thus true i - | Phence i -> - assert (not (_then || _thus)); - do_proof_instr_gen true true i - | Pcut c -> - instr_cut mk_stat_or_thesis _thus _then c - | Psuffices c -> - instr_suffices _then c - | Prew (s,c) -> - assert (not _then); - instr_rew _thus s c - | Pconsider (c,hyps) -> consider_tac c hyps - | Pgiven hyps -> given_tac hyps - | Passume hyps -> assume_tac hyps - | Plet hyps -> assume_tac hyps - | Pclaim st -> instr_claim false st - | Pfocus st -> instr_claim true st - | Ptake witl -> take_tac witl - | Pdefine (id,args,body) -> define_tac id args body - | Pcast (id,typ) -> cast_tac id typ - | Pper (et,cs) -> per_tac et cs - | Psuppose hyps -> suppose_tac hyps - | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps - | Pend (B_elim et) -> end_tac et - | Pend _ -> anomaly "Not applicable" - | Pescape -> escape_tac - -let eval_instr {instr=instr} = - do_proof_instr_gen false false instr - -let rec preprocess pts instr = - match instr with - Phence i |Pthus i | Pthen i -> preprocess pts i - | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ - | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ - | Pdefine (_,_,_) | Pper _ | Prew _ -> - check_not_per pts; - true,pts - | Pescape -> - check_not_per pts; - true,pts - | Pcase _ | Psuppose _ | Pend (B_elim _) -> - true,close_previous_case pts - | Pend bt -> - false,close_block bt pts - -let rec postprocess pts instr = - match instr with - Phence i | Pthus i | Pthen i -> postprocess pts i - | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_) - | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> pts - | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ - | Pescape -> nth_unproven 1 pts - | Pend (B_elim ET_Induction) -> - begin - let pf = proof_of_pftreestate pts in - let (pfterm,_) = extract_open_pftreestate pts in - let env = Evd.evar_env (goal_of_proof pf) in - try - Inductiveops.control_only_guard env pfterm; - goto_current_focus_or_top (mark_as_done pts) - with - Type_errors.TypeError(env, - Type_errors.IllFormedRecBody(_,_,_,_,_)) -> - anomaly "\"end induction\" generated an ill-formed fixpoint" - end - | Pend _ -> - goto_current_focus_or_top (mark_as_done pts) - -let do_instr raw_instr pts = - let has_tactic,pts1 = preprocess pts raw_instr.instr in - let pts2 = - if has_tactic then - let gl = nth_goal_of_pftreestate 1 pts1 in - let env= pf_env gl in - let sigma= project gl in - let ist = {ltacvars = ([],[]); ltacrecvars = []; - gsigma = sigma; genv = env} in - let glob_instr = intern_proof_instr ist raw_instr in - let instr = - interp_proof_instr (get_its_info gl) sigma env glob_instr in - let lock_focus = is_focussing_instr instr.instr in - let marker= Proof_instr (lock_focus,instr) in - solve_nth_pftreestate 1 - (abstract_operation marker (tclTHEN (eval_instr instr) clean_tmp)) pts1 - else pts1 in - postprocess pts2 raw_instr.instr - -let proof_instr raw_instr = - Pfedit.mutate (do_instr raw_instr) - -(* - -(* STUFF FOR ITERATED RELATIONS *) -let decompose_bin_app t= - let hd,args = destApp - -let identify_transitivity_lemma c = - let varx,tx,c1 = destProd c in - let vary,ty,c2 = destProd (pop c1) in - let varz,tz,c3 = destProd (pop c2) in - let _,p1,c4 = destProd (pop c3) in - let _,lp2,lp3 = destProd (pop c4) in - let p2=pop lp2 in - let p3=pop lp3 in -*) - diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli deleted file mode 100644 index 5af60a1b..00000000 --- a/tactics/decl_proof_instr.mli +++ /dev/null @@ -1,119 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit -val return_from_tactic_mode: unit -> unit - -val register_automation_tac: tactic -> unit - -val automation_tac : tactic - -val daimon_subtree: pftreestate -> pftreestate - -val concl_refiner: - Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr - -val do_instr: Decl_expr.raw_proof_instr -> pftreestate -> pftreestate -val proof_instr: Decl_expr.raw_proof_instr -> unit - -val tcl_change_info : Decl_mode.pm_info -> tactic - -val mark_proof_tree_as_done : Proof_type.proof_tree -> Proof_type.proof_tree - -val mark_as_done : pftreestate -> pftreestate - -val execute_cases : - Names.name -> - Decl_mode.per_info -> - (Term.constr -> Proof_type.tactic) -> - (Names.Idset.elt * (Term.constr option * Term.constr list) list) list -> - Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic - -val tree_of_pats : - identifier * (int * int) -> (Rawterm.cases_pattern*recpath) list list -> - split_tree - -val add_branch : - identifier * (int * int) -> (Rawterm.cases_pattern*recpath) list list -> - split_tree -> split_tree - -val append_branch : - identifier *(int * int) -> int -> (Rawterm.cases_pattern*recpath) list list -> - (Names.Idset.t * Decl_mode.split_tree) option -> - (Names.Idset.t * Decl_mode.split_tree) option - -val append_tree : - identifier * (int * int) -> int -> (Rawterm.cases_pattern*recpath) list list -> - split_tree -> split_tree - -val build_dep_clause : Term.types Decl_expr.statement list -> - Decl_expr.proof_pattern -> - Decl_mode.per_info -> - (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis) - Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types - -val register_dep_subcase : - Names.identifier * (int * int) -> - Environ.env -> - Decl_mode.per_info -> - Rawterm.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind - -val thesis_for : Term.constr -> - Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr - -val close_previous_case : pftreestate -> pftreestate - -val pop_stacks : - (Names.identifier * - (Term.constr option * Term.constr list) list) list -> - (Names.identifier * - (Term.constr option * Term.constr list) list) list - -val push_head : Term.constr -> - Names.Idset.t -> - (Names.identifier * - (Term.constr option * Term.constr list) list) list -> - (Names.identifier * - (Term.constr option * Term.constr list) list) list - -val push_arg : Term.constr -> - (Names.identifier * - (Term.constr option * Term.constr list) list) list -> - (Names.identifier * - (Term.constr option * Term.constr list) list) list - -val hrec_for: - Names.identifier -> - Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> - Names.identifier -> Term.constr - -val consider_match : - bool -> - (Names.Idset.elt*bool) list -> - Names.Idset.elt list -> - (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list -> - Proof_type.tactic - -val init_tree: - Names.Idset.t -> - Names.inductive -> - int option * Declarations.wf_paths -> - (int -> - (int option * Declarations.recarg Rtree.t) array -> - (Names.Idset.t * Decl_mode.split_tree) option) -> - Decl_mode.split_tree - -val set_refine : (Evd.open_constr -> Proof_type.tactic) -> unit diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index 041e58df..fd924707 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = declare_object {(default_object "DESTRUCT-HYP-CONCL-DATA") with cache_function = cache_dd; open_function = (fun i o -> if i=1 then cache_dd o); @@ -292,7 +290,7 @@ let applyDestructor cls discard dd gls = match cl, dd.d_code with | Some id, (Some x, tac) -> let arg = - ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in + ConstrMayEval(ConstrTerm (GRef(dummy_loc,VarRef id),None)) in TacLetIn (false, [(dummy_loc, x), arg], tac) | None, (None, tac) -> tac | _, (Some _,_) -> error "Destructor expects an hypothesis." diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli index 4cde3b49..1bdeed6a 100644 --- a/tactics/dhyp.mli +++ b/tactics/dhyp.mli @@ -1,20 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* tactic) -> unit @@ -28,5 +24,5 @@ val h_auto_tdb : int option -> tactic val add_destructor_hint : Vernacexpr.locality_flag -> identifier -> (bool,unit) Tacexpr.location -> - Rawterm.patvar list * Pattern.constr_pattern -> int -> + Glob_term.patvar list * Pattern.constr_pattern -> int -> glob_tactic_expr -> unit diff --git a/tactics/dn.mli b/tactics/dn.mli index 3cb52a56..662ac19a 100644 --- a/tactics/dn.mli +++ b/tactics/dn.mli @@ -17,7 +17,7 @@ sig val create : unit -> t - (* [add t f (tree,inf)] adds a structured object [tree] together with + (** [add t f (tree,inf)] adds a structured object [tree] together with the associated information [inf] to the table [t]; the function [f] is used to translated [tree] into its prefix decomposition: [f] must decompose any tree into a label characterizing its root node and @@ -31,7 +31,8 @@ sig type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res -(* [lookup t f tree] looks for trees (and their associated + +(** [lookup t f tree] looks for trees (and their associated information) in table [t] such that the structured object [tree] matches against them; [f] is used to translated [tree] into its prefix decomposition: [f] must decompose any tree into a label diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index e0cdbcfa..9966fb77 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (tclTHEN t prol)) (one_step l gl))) gl let prolog_tac l n gl = + let l = List.map (prepare_hint (pf_env gl)) l in let n = match n with | ArgArg n -> n @@ -81,7 +79,7 @@ let prolog_tac l n gl = errorlabstrm "Prolog.prolog" (str "Prolog failed.") TACTIC EXTEND prolog -| [ "prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ] +| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ] END open Auto @@ -95,7 +93,7 @@ let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) let unify_e_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in - let _ = clenv_unique_resolver false ~flags clenv' gls in + let _ = clenv_unique_resolver ~flags clenv' gls in h_simplest_eapply c gls let rec e_trivial_fail_db db_list local_db goal = @@ -170,7 +168,7 @@ let find_first_goal gls = type search_state = { depth : int; (*r depth of search before failing *) - tacres : goal list sigma * validation; + tacres : goal list sigma; last_tactic : std_ppcmds Lazy.t; dblist : Auto.hint_db list; localdb : Auto.hint_db list } @@ -179,15 +177,15 @@ module SearchProblem = struct type state = search_state - let success s = (sig_it (fst s.tacres)) = [] + let success s = (sig_it s.tacres) = [] let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) let pr_goals gls = - let evars = Evarutil.nf_evars (Refiner.project gls) in + let evars = Evarutil.nf_evar_map (Refiner.project gls) in prlist (pr_ev evars) (sig_it gls) - let filter_tactics (glls,v) l = + let filter_tactics glls l = (* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* let evars = Evarutil.nf_evars (Refiner.project glls) in *) (* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) @@ -195,11 +193,10 @@ module SearchProblem = struct | [] -> [] | (tac,pptac) :: tacl -> try - let (lgls,ptl) = apply_tac_list tac glls in - let v' p = v (ptl p) in + let lgls = apply_tac_list tac glls in (* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) - ((lgls,v'),pptac) :: aux tacl + (lgls,pptac) :: aux tacl with e -> Refiner.catch_failerror e; aux tacl in aux l @@ -207,14 +204,14 @@ module SearchProblem = struct number of remaining goals. *) let compare s s' = let d = s'.depth - s.depth in - let nbgoals s = List.length (sig_it (fst s.tacres)) in + let nbgoals s = List.length (sig_it s.tacres) in if d <> 0 then d else nbgoals s - nbgoals s' let branching s = if s.depth = 0 then [] else - let lg = fst s.tacres in + let lg = s.tacres in let nbgl = List.length (sig_it lg) in assert (nbgl > 0); let g = find_first_goal lg in @@ -232,7 +229,7 @@ module SearchProblem = struct in let intro_tac = List.map - (fun ((lgls,_) as res,pp) -> + (fun (lgls as res,pp) -> let g' = first_goal lgls in let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') @@ -248,7 +245,7 @@ module SearchProblem = struct filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) in List.map - (fun ((lgls,_) as res, pp) -> + (fun (lgls as res, pp) -> let nbgl' = List.length (sig_it lgls) in if nbgl' < nbgl then { depth = s.depth; tacres = res; last_tactic = pp; @@ -294,7 +291,7 @@ let e_breadth_search debug n db_list local_db gl = with Not_found -> error "eauto: breadth first search failed." let e_search_auto debug (in_depth,p) lems db_list gl = - let local_db = make_local_hint_db true lems gl in + let local_db = make_local_hint_db ~ts:full_transparent_state true lems gl in if in_depth then e_depth_search debug p db_list local_db gl else @@ -306,18 +303,12 @@ let eauto_with_bases debug np lems db_list = tclTRY (e_search_auto debug np lems db_list) let eauto debug np lems dbnames = - let db_list = - List.map - (fun x -> - try searchtable_map x - with Not_found -> error ("No such Hint database: "^x^".")) - ("core"::dbnames) - in + let db_list = make_db_list dbnames in tclTRY (e_search_auto debug np lems db_list) let full_eauto debug n lems gl = let dbnames = current_db_names () in - let dbnames = list_subtract dbnames ["v62"] in + let dbnames = list_remove "v62" dbnames in let db_list = List.map searchtable_map dbnames in tclTRY (e_search_auto debug n lems db_list) gl @@ -349,19 +340,20 @@ ARGUMENT EXTEND hintbases | [ ] -> [ Some [] ] END -let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc +let pr_constr_coma_sequence prc _ _ = + prlist_with_sep pr_comma (fun (_,c) -> prc c) ARGUMENT EXTEND constr_coma_sequence - TYPED AS constr_list + TYPED AS open_constr_list PRINTED BY pr_constr_coma_sequence -| [ constr(c) "," constr_coma_sequence(l) ] -> [ c::l ] -| [ constr(c) ] -> [ [c] ] +| [ open_constr(c) "," constr_coma_sequence(l) ] -> [ c::l ] +| [ open_constr(c) ] -> [ [c] ] END -let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc +let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using (fun (_,c) -> prc c) ARGUMENT EXTEND auto_using - TYPED AS constr_list + TYPED AS open_constr_list PRINTED BY pr_auto_using | [ "using" constr_coma_sequence(l) ] -> [ l ] | [ ] -> [ [] ] @@ -414,19 +406,6 @@ let autounfold db cls gl = | OnConcl occs -> tac occs None) cls gl -let autosimpl db cl = - let unfold_of_elts constr (b, elts) = - if not b then - List.map (fun c -> all_occurrences, constr c) elts - else [] - in - let unfolds = List.concat (List.map (fun dbname -> - let db = searchtable_map dbname in - let (ids, csts) = Hint_db.transparent_state db in - unfold_of_elts (fun x -> EvalConstRef x) (Cpred.elements csts) @ - unfold_of_elts (fun x -> EvalVarRef x) (Idpred.elements ids)) db) - in unfold_option unfolds cl - open Extraargs TACTIC EXTEND autounfold @@ -520,3 +499,55 @@ END TACTIC EXTEND convert_concl_no_check | ["convert_concl_no_check" constr(x) ] -> [ convert_concl_no_check x DEFAULTcast ] END + + +let pr_hints_path_atom prc _ _ a = + match a with + | PathAny -> str"." + | PathHints grs -> + prlist_with_sep pr_spc Printer.pr_global grs + +ARGUMENT EXTEND hints_path_atom + TYPED AS hints_path_atom + PRINTED BY pr_hints_path_atom +| [ global_list(g) ] -> [ PathHints (List.map Nametab.global g) ] +| [ "*" ] -> [ PathAny ] +END + +let pr_hints_path prc prx pry c = + let rec aux = function + | PathAtom a -> pr_hints_path_atom prc prx pry a + | PathStar p -> str"(" ++ aux p ++ str")*" + | PathSeq (p, p') -> aux p ++ spc () ++ aux p' + | PathOr (p, p') -> str "(" ++ aux p ++ str"|" ++ aux p' ++ str")" + | PathEmpty -> str"ø" + | PathEpsilon -> str"ε" + in aux c + +ARGUMENT EXTEND hints_path + TYPED AS hints_path + PRINTED BY pr_hints_path +| [ "(" hints_path(p) ")" ] -> [ p ] +| [ "!" hints_path(p) ] -> [ PathStar p ] +| [ "emp" ] -> [ PathEmpty ] +| [ "eps" ] -> [ PathEpsilon ] +| [ hints_path_atom(a) ] -> [ PathAtom a ] +| [ hints_path(p) "|" hints_path(q) ] -> [ PathOr (p, q) ] +| [ hints_path(p) ";" hints_path(q) ] -> [ PathSeq (p, q) ] +END + +let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases + +ARGUMENT EXTEND opthints + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ ":" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ None ] +END + +VERNAC COMMAND EXTEND HintCut +| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ + let entry = HintsCutEntry p in + Auto.add_hints (Vernacexpr.use_section_locality ()) + (match dbnames with None -> ["core"] | Some l -> l) entry ] +END diff --git a/tactics/eauto.mli b/tactics/eauto.mli index b40261b6..68ec42f4 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -1,12 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> tactic -val gen_eauto : bool -> bool * int -> constr list -> +val gen_eauto : bool -> bool * int -> open_constr list -> hint_db_name list option -> tactic - val eauto_with_bases : bool -> bool * int -> - Term.constr list -> Auto.hint_db list -> Proof_type.tactic + open_constr list -> Auto.hint_db list -> Proof_type.tactic val autounfold : hint_db_name list -> Tacticals.clause -> tactic diff --git a/tactics/elim.ml b/tactics/elim.ml index f3517ea6..1ff8800f 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* false -let inductive_of = function - | IndRef ity -> ity - | r -> - errorlabstrm "Decompose" - (Printer.pr_global r ++ str " is not an inductive type.") - let decompose_these c l gls = let indl = (*List.map inductive_of*) l in general_decompose (fun (_,t) -> head_in gls indl t) c gls @@ -136,8 +128,6 @@ let decompose_or c gls = (fun (_,t) -> is_disjunction t) c gls -let inj_open c = (Evd.empty,c) - let h_decompose l c = Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l) diff --git a/tactics/elim.mli b/tactics/elim.mli index c6aecad7..48a7ca68 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -1,23 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* tactic) -> branch_args -> tactic @@ -34,5 +30,5 @@ val h_decompose : inductive list -> constr -> tactic val h_decompose_or : constr -> tactic val h_decompose_and : constr -> tactic -val double_ind : Rawterm.quantified_hypothesis -> Rawterm.quantified_hypothesis -> tactic -val h_double_induction : Rawterm.quantified_hypothesis -> Rawterm.quantified_hypothesis->tactic +val double_ind : Glob_term.quantified_hypothesis -> Glob_term.quantified_hypothesis -> tactic +val h_double_induction : Glob_term.quantified_hypothesis -> Glob_term.quantified_hypothesis->tactic diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index c60938ed..fbf36c1c 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ decideEquality c1 c2 ] | [ "decide" "equality" ] -> [ decideEqualityGoal ] END diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 88931415..779fe265 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constrargs then + 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) @@ -176,7 +174,7 @@ let build_sym_scheme env ind = [|cstr (nrealargs+1)|])))) let sym_scheme_kind = - declare_individual_scheme_object "_sym" + declare_individual_scheme_object "_sym_internal" (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind) (**********************************************************************) @@ -635,27 +633,14 @@ let rew_l2r_forward_dep_scheme_kind = (**********************************************************************) (* Non-dependent rewrite from either left-to-right in conclusion or *) (* right-to-left in hypotheses: both l2r_rew and r2l_forward_rew are *) -(* potential candidates. However r2l_forward_rew introduces a blocked *) -(* beta-expansion that blocks in turn the guard condition if this *) -(* one does not support commutative cuts while l2r_rew does not *) -(* support non symmetrical equalities, so... *) -(**********************************************************************) - -(**********************************************************************) -(* ... we use l2r_rew for the symmetrical case: *) +(* potential candidates. Since l2r_rew needs a symmetrical equality, *) +(* we adopt r2l_forward_rew (this one introduces a blocked beta- *) +(* expansion but since the guard condition supports commutative cuts *) +(* this is not a problem; we need though a fix to adjust it to the *) +(* standard form of schemes in Coq) *) (**********************************************************************) let rew_l2r_scheme_kind = declare_individual_scheme_object "_rew_r" - (fun ind -> build_l2r_rew_scheme false (Global.env()) ind InType) - -(**********************************************************************) -(* ... and r2l_forward_rew for the non-symmetrical case, even though *) -(* it may break the guard condition. Moreover, its standard form *) -(* needs the inductive hypothesis not in last position what breaks *) -(* the order of goals and need a fix: *) -(**********************************************************************) -let rew_asym_scheme_kind = - declare_individual_scheme_object "_rew_r_asym" (fun ind -> fix_r2l_forward_rew_scheme (build_r2l_forward_rew_scheme false (Global.env()) ind InType)) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index 08b3b05c..870ca6b6 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -1,21 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* env -> inductive -> sorts_family -> constr val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> constr @@ -32,7 +29,7 @@ val build_r2l_forward_rew_scheme : val build_l2r_forward_rew_scheme : bool -> env -> inductive -> sorts_family -> constr -(* Builds a symmetry scheme for a symmetrical equality type *) +(** Builds a symmetry scheme for a symmetrical equality type *) val build_sym_scheme : env -> inductive -> constr val sym_scheme_kind : individual scheme_kind @@ -40,7 +37,7 @@ val sym_scheme_kind : individual scheme_kind val build_sym_involutive_scheme : env -> inductive -> constr val sym_involutive_scheme_kind : individual scheme_kind -(* Builds a congruence scheme for an equality type *) +(** Builds a congruence scheme for an equality type *) val congr_scheme_kind : individual scheme_kind val build_congr : env -> constr * constr -> inductive -> constr diff --git a/tactics/equality.ml b/tactics/equality.ml index a25f88e3..10fd0fef 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* !discriminate_introduction); @@ -66,6 +65,7 @@ let _ = (* Rewriting tactics *) type dep_proof_flag = bool (* true = support rewriting dependent proofs *) +type freeze_evars_flag = bool (* true = don't instantiate existing evars *) type orientation = bool @@ -84,18 +84,42 @@ type conditions = let rewrite_unif_flags = { Unification.modulo_conv_on_closed_terms = None; - Unification.use_metas_eagerly = true; + Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; + Unification.modulo_delta_types = empty_transparent_state; + Unification.check_applied_meta_types = true; Unification.resolve_evars = true; - Unification.use_evars_pattern_unification = true; + Unification.use_pattern_unification = true; + Unification.use_meta_bound_pattern_unification = true; + Unification.frozen_evars = ExistentialSet.empty; + Unification.restrict_conv_on_strict_subterms = false; + Unification.modulo_betaiota = false; + Unification.modulo_eta = true; + Unification.allow_K_in_toplevel_higher_order_unification = false + (* allow_K does not matter in practice because calls w_typed_unify *) } +let freeze_initial_evars sigma flags clause = + (* We take evars of the type: this may include old evars! For excluding *) + (* all old evars, including the ones occurring in the rewriting lemma, *) + (* we would have to take the clenv_value *) + let newevars = Evd.collect_evars (clenv_type clause) in + let evars = + fold_undefined (fun evk _ evars -> + if ExistentialSet.mem evk newevars then evars + else ExistentialSet.add evk evars) + sigma ExistentialSet.empty in + { flags with Unification.frozen_evars = evars } + +let make_flags frzevars sigma flags clause = + if frzevars then freeze_initial_evars sigma flags clause else flags + let side_tac tac sidetac = match sidetac with | None -> tac | Some sidetac -> tclTHENSFIRSTn tac [|tclIDTAC|] sidetac -let instantiate_lemma_all env sigma gl c ty l l2r concl = +let instantiate_lemma_all frzevars env sigma gl c ty l l2r concl = let eqclause = Clenv.make_clenv_binding { gl with sigma = sigma } (c,ty) l in let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in let rec split_last_two = function @@ -105,13 +129,12 @@ let instantiate_lemma_all env sigma gl c ty l l2r concl = | _ -> error "The term provided is not an applied relation." in let others,(c1,c2) = split_last_two args in let try_occ (evd', c') = - let cl' = {eqclause with evd = evd'} in - let mvs = clenv_dependent false cl' in - clenv_pose_metas_as_evars cl' mvs + clenv_pose_dependent_evars true {eqclause with evd = evd'} in + let flags = make_flags frzevars sigma rewrite_unif_flags eqclause in let occs = - Unification.w_unify_to_subterm_all ~flags:rewrite_unif_flags env - ((if l2r then c1 else c2),concl) eqclause.evd + Unification.w_unify_to_subterm_all ~flags env eqclause.evd + ((if l2r then c1 else c2),concl) in List.map try_occ occs let instantiate_lemma env sigma gl c ty l l2r concl = @@ -121,28 +144,61 @@ let instantiate_lemma env sigma gl c ty l l2r concl = let eqclause = Clenv.make_clenv_binding gl (c,t) l in [eqclause] -let rewrite_elim with_evars c e ?(allow_K=true) = - general_elim_clause_gen (elimination_clause_scheme with_evars allow_K) c e +let rewrite_conv_closed_unif_flags = { + Unification.modulo_conv_on_closed_terms = Some full_transparent_state; + (* We have this flag for historical reasons, it has e.g. the consequence *) + (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) + + Unification.use_metas_eagerly_in_conv_on_closed_terms = true; + (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) + (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) + + Unification.modulo_delta = empty_transparent_state; + Unification.modulo_delta_types = full_transparent_state; + Unification.check_applied_meta_types = true; + Unification.resolve_evars = false; + Unification.use_pattern_unification = true; + (* To rewrite "?n x y" in "y+x=0" when ?n is *) + (* a preexisting evar of the goal*) + + Unification.use_meta_bound_pattern_unification = true; + + Unification.frozen_evars = ExistentialSet.empty; + (* This is set dynamically *) + + Unification.restrict_conv_on_strict_subterms = false; + Unification.modulo_betaiota = false; + Unification.modulo_eta = true; + Unification.allow_K_in_toplevel_higher_order_unification = false +} + +let rewrite_elim with_evars frzevars c e gl = + let flags = + make_flags frzevars (project gl) rewrite_conv_closed_unif_flags c in + general_elim_clause_gen (elimination_clause_scheme with_evars ~flags) c e gl -let rewrite_elim_in with_evars id c e = - general_elim_clause_gen (elimination_in_clause_scheme with_evars id) c e +let rewrite_elim_in with_evars frzevars id c e gl = + let flags = + make_flags frzevars (project gl) rewrite_conv_closed_unif_flags c in + general_elim_clause_gen + (elimination_in_clause_scheme with_evars ~flags id) c e gl (* Ad hoc asymmetric general_elim_clause *) -let general_elim_clause with_evars cls rew elim = +let general_elim_clause with_evars frzevars cls rew elim = try (match cls with | None -> (* was tclWEAK_PROGRESS which only fails for tactics generating one subgoal and did not fail for useless conditional rewritings generating an extra condition *) - tclNOTSAMEGOAL (rewrite_elim with_evars rew elim ~allow_K:false) - | Some id -> rewrite_elim_in with_evars id rew elim) - with Pretype_errors.PretypeError (env, - (Pretype_errors.NoOccurrenceFound (c', _))) -> + tclNOTSAMEGOAL (rewrite_elim with_evars frzevars rew elim) + | Some id -> rewrite_elim_in with_evars frzevars id rew elim) + with Pretype_errors.PretypeError (env,evd, + Pretype_errors.NoOccurrenceFound (c', _)) -> raise (Pretype_errors.PretypeError - (env, (Pretype_errors.NoOccurrenceFound (c', cls)))) + (env,evd,Pretype_errors.NoOccurrenceFound (c', cls))) -let general_elim_clause with_evars tac cls sigma c t l l2r elim gl = +let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl = let all, firstonly, tac = match tac with | None -> false, false, None @@ -151,12 +207,15 @@ let general_elim_clause with_evars tac cls sigma c t l l2r elim gl = | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac) in let cs = - (if not all then instantiate_lemma else instantiate_lemma_all) + (if not all then instantiate_lemma else instantiate_lemma_all frzevars) (pf_env gl) sigma gl c t l l2r (match cls with None -> pf_concl gl | Some id -> pf_get_hyp_typ gl id) in let try_clause c = - side_tac (tclTHEN (Refiner.tclEVARS c.evd) (general_elim_clause with_evars cls c elim)) tac + side_tac + (tclTHEN + (Refiner.tclEVARS c.evd) + (general_elim_clause with_evars frzevars cls c elim)) tac in if firstonly then tclFIRST (List.map try_clause cs) gl @@ -180,8 +239,8 @@ let register_is_applied_rewrite_relation = (:=) is_applied_rewrite_relation let find_elim hdcncl lft2rgt dep cls args gl = let inccl = (cls = None) in - if (hdcncl = constr_of_reference (Coqlib.glob_eq) || - hdcncl = constr_of_reference (Coqlib.glob_jmeq) && + if (eq_constr hdcncl (constr_of_reference (Coqlib.glob_eq)) || + eq_constr hdcncl (constr_of_reference (Coqlib.glob_jmeq)) && pf_conv_x gl (List.nth args 0) (List.nth args 2)) && not dep || Flags.version_less_or_equal Flags.V8_2 then @@ -195,7 +254,7 @@ let find_elim hdcncl lft2rgt dep cls args gl = let c1 = destConst pr1 in let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in let l' = label_of_id (add_suffix (id_of_label l) "_r") in - let c1' = Global.constant_of_delta (make_con mp dp l') in + let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in begin try let _ = Global.lookup_constant c1' in @@ -211,20 +270,16 @@ let find_elim hdcncl lft2rgt dep cls args gl = assert false else let scheme_name = match dep, lft2rgt, inccl with - (* Non dependent case with symmetric equality *) - | false, Some true, true | false, Some false, false -> rew_l2r_scheme_kind - | false, Some false, true | false, Some true, false -> rew_r2l_scheme_kind - (* Dependent case with symmetric equality *) + (* Non dependent case *) + | false, Some true, true -> rew_l2r_scheme_kind + | false, Some true, false -> rew_r2l_scheme_kind + | false, _, false -> rew_l2r_scheme_kind + | false, _, true -> rew_r2l_scheme_kind + (* Dependent case *) | true, Some true, true -> rew_l2r_dep_scheme_kind | true, Some true, false -> rew_l2r_forward_dep_scheme_kind - | true, Some false, true -> rew_r2l_dep_scheme_kind - | true, Some false, false -> rew_r2l_forward_dep_scheme_kind - (* Non dependent case with non-symmetric rewriting lemma *) - | false, None, true -> rew_r2l_scheme_kind - | false, None, false -> rew_asym_scheme_kind - (* Dependent case with non-symmetric rewriting lemma *) - | true, None, true -> rew_r2l_dep_scheme_kind - | true, None, false -> rew_r2l_forward_dep_scheme_kind + | true, _, true -> rew_r2l_dep_scheme_kind + | true, _, false -> rew_r2l_forward_dep_scheme_kind in match kind_of_term hdcncl with | Ind ind -> mkConst (find_scheme scheme_name ind) @@ -234,12 +289,12 @@ let type_of_clause gl = function | None -> pf_concl gl | Some id -> pf_get_hyp_typ gl id -let leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars dep_proof_ok gl hdcncl = +let leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars frzevars dep_proof_ok gl hdcncl = let isatomic = isProd (whd_zeta hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let dep = dep_proof_ok && dep_fun c (type_of_clause gl cls) in let elim = find_elim hdcncl lft2rgt dep cls (snd (decompose_app t)) gl in - general_elim_clause with_evars tac cls sigma c t l + general_elim_clause with_evars frzevars tac cls sigma c t l (match lft2rgt with None -> false | Some b -> b) {elimindex = None; elimbody = (elim,NoBindings)} gl @@ -259,7 +314,7 @@ let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac) (* Main function for dispatching which kind of rewriting it is about *) -let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac +let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac ((c,l) : constr with_bindings) with_evars gl = if occs <> all_occurrences then ( rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl) @@ -272,7 +327,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c (it_mkProd_or_LetIn t rels) - l with_evars dep_proof_ok gl hdcncl + l with_evars frzevars dep_proof_ok gl hdcncl | None -> try rewrite_side_tac (!general_rewrite_clause cls @@ -284,27 +339,31 @@ let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac | Some (hdcncl,args) -> let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c - (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars dep_proof_ok gl hdcncl + (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok gl hdcncl | None -> raise e (* error "The provided term does not end with an equality or a declared rewrite relation." *) let general_rewrite_ebindings = general_rewrite_ebindings_clause None -let general_rewrite_bindings l2r occs dep_proof_ok ?tac (c,bl) = - general_rewrite_ebindings_clause None l2r occs dep_proof_ok ?tac (c,bl) +let general_rewrite_bindings l2r occs frzevars dep_proof_ok ?tac (c,bl) = + general_rewrite_ebindings_clause None l2r occs + frzevars dep_proof_ok ?tac (c,bl) -let general_rewrite l2r occs dep_proof_ok ?tac c = - general_rewrite_bindings l2r occs dep_proof_ok ?tac (c,NoBindings) false +let general_rewrite l2r occs frzevars dep_proof_ok ?tac c = + general_rewrite_bindings l2r occs + frzevars dep_proof_ok ?tac (c,NoBindings) false -let general_rewrite_ebindings_in l2r occs dep_proof_ok ?tac id = - general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac +let general_rewrite_ebindings_in l2r occs frzevars dep_proof_ok ?tac id = + general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac -let general_rewrite_bindings_in l2r occs dep_proof_ok ?tac id (c,bl) = - general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac (c,bl) +let general_rewrite_bindings_in l2r occs frzevars dep_proof_ok ?tac id (c,bl) = + general_rewrite_ebindings_clause (Some id) l2r occs + frzevars dep_proof_ok ?tac (c,bl) -let general_rewrite_in l2r occs dep_proof_ok ?tac id c = - general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac (c,NoBindings) +let general_rewrite_in l2r occs frzevars dep_proof_ok ?tac id c = + general_rewrite_ebindings_clause (Some id) l2r occs + frzevars dep_proof_ok ?tac (c,NoBindings) let general_multi_rewrite l2r with_evars ?tac c cl = let occs_of = on_snd (List.fold_left @@ -320,12 +379,12 @@ let general_multi_rewrite l2r with_evars ?tac c cl = | [] -> tclIDTAC | ((occs,id),_) :: l -> tclTHENFIRST - (general_rewrite_ebindings_in l2r (occs_of occs) true ?tac id c with_evars) + (general_rewrite_ebindings_in l2r (occs_of occs) false true ?tac id c with_evars) (do_hyps l) in if cl.concl_occs = no_occurrences_expr then do_hyps l else tclTHENFIRST - (general_rewrite_ebindings l2r (occs_of cl.concl_occs) true ?tac c with_evars) + (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) (do_hyps l) | None -> (* Otherwise, if we are told to rewrite in all hypothesis via the @@ -334,7 +393,7 @@ let general_multi_rewrite l2r with_evars ?tac c cl = | [] -> (fun gl -> error "Nothing to rewrite.") | id :: l -> tclIFTHENTRYELSEMUST - (general_rewrite_ebindings_in l2r all_occurrences true ?tac id c with_evars) + (general_rewrite_ebindings_in l2r all_occurrences false true ?tac id c with_evars) (do_hyps_atleastonce l) in let do_hyps gl = @@ -346,7 +405,7 @@ let general_multi_rewrite l2r with_evars ?tac c cl = in if cl.concl_occs = no_occurrences_expr then do_hyps else tclIFTHENTRYELSEMUST - (general_rewrite_ebindings l2r (occs_of cl.concl_occs) true ?tac c with_evars) + (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) do_hyps type delayed_open_constr_with_bindings = @@ -371,8 +430,8 @@ let general_multi_multi_rewrite with_evars l cl tac = | (l2r,m,c)::l -> tclTHENFIRST (doN l2r c m) (loop l) in loop l -let rewriteLR = general_rewrite true all_occurrences true -let rewriteRL = general_rewrite false all_occurrences true +let rewriteLR = general_rewrite true all_occurrences true true +let rewriteRL = general_rewrite false all_occurrences true true (* Replacing tactics *) @@ -512,7 +571,7 @@ let discriminable env sigma t1 t2 = let injectable env sigma t1 t2 = match find_positions env sigma t1 t2 with - | Inl _ | Inr [] -> false + | Inl _ | Inr [] | Inr [([],_,_)] -> false | Inr _ -> true @@ -631,7 +690,7 @@ let construct_discriminator sigma env dirn c sort = CP : changed assert false in a more informative error *) errorlabstrm "Equality.construct_discriminator" - (str "Cannot discriminate on inductive constructors with + (str "Cannot discriminate on inductive constructors with \ dependent types.") in let (ind,_) = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in @@ -682,14 +741,13 @@ let gen_absurdity id gl = *) let ind_scheme_of_eq lbeq = - let ind = destInd lbeq.eq in - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_inductive (destInd 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 - mkConst (find_scheme kind ind) + mkConst (find_scheme kind (destInd lbeq.eq)) let discrimination_pf e (t,t1,t2) discriminator lbeq = @@ -894,8 +952,8 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let rty = beta_applist(p_i_minus_1,[ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in match - Evd.existential_opt_value !evdref - (destEvar ev) + Evd.existential_opt_value !evdref + (destEvar ev) with | Some w -> let w_type = type_of env sigma w in @@ -1057,6 +1115,8 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause = | Inr [] -> errorlabstrm "Equality.inj" (str"Nothing to do, it is an equality between convertible terms.") + | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 -> + errorlabstrm "Equality.inj" (str"Nothing to inject.") | Inr posns -> (* Est-ce utile à partir du moment où les arguments projetés subissent "nf" ? let t1 = try_delta_expand env sigma t1 in @@ -1186,26 +1246,37 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls = 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 cdrtyp = beta_applist (p,[car]) in - ((car,a),car_code)::(decomprec cdr_code cdr cdrtyp) + List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) with PatternMatchingFailure -> - [((ex,exty),inner_code)] + [] + in + [((ex,exty),inner_code)]::iterated_decomp in - List.split (decomprec (mkRel 1) c t) + 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 + (* We find all possible decompositions *) + let decomps1 = decomp_tuple_term env dep_pair1 typ in + let decomps2 = decomp_tuple_term env dep_pair2 typ in + (* We adjust to the shortest decomposition *) + let n = min (List.length decomps1) (List.length decomps2) in + let decomp1 = List.nth decomps1 (n-1) in + let decomp2 = List.nth decomps2 (n-1) in (* We rewrite dep_pair1 ... *) - let e1_list,proj_list = decomp_tuple_term env dep_pair1 typ in + let e1_list,proj_list = List.split decomp1 in + (* ... and use dep_pair2 to compute the expected goal *) + let e2_list,_ = List.split decomp2 in + (* We build the expected goal *) let abst_B = List.fold_right (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in - (* ... and use dep_pair2 to compute the expected goal *) - let e2_list,_ = decomp_tuple_term env dep_pair2 typ in let pred_body = beta_applist(abst_B,proj_list) in let expected_goal = beta_applist (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) @@ -1330,34 +1401,21 @@ exception FoundHyp of (identifier * constr * bool) let is_eq_x gl x (id,_,c) = try let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in - if (x = lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); - if (x = rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) + 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 PatternMatchingFailure -> () -let subst_one dep_proof_ok x gl = - let hyps = pf_hyps gl in - let (_,xval,_) = pf_get_hyp gl x in - (* If x has a body, simply replace x with body and clear x *) - if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else - (* x is a variable: *) - let varx = mkVar x in - (* Find a non-recursive definition for x *) - let (hyp,rhs,dir) = - try - let test hyp _ = is_eq_x gl varx hyp in - Sign.fold_named_context test ~init:() hyps; - errorlabstrm "Subst" - (str "Cannot find any non-recursive equality over " ++ pr_id x ++ - str".") - with FoundHyp res -> res - in +(* Rewrite "hyp:x=rhs" or "hyp:rhs=x" (if dir=false) everywhere and + erase hyp and x; proceed by generalizing all dep hyps *) + +let subst_one dep_proof_ok x (hyp,rhs,dir) gl = (* The set of hypotheses using x *) let depdecls = let test (id,_,c as dcl) = if id <> hyp && occur_var_in_decl (pf_env gl) x dcl then dcl else failwith "caught" in - List.rev (map_succeed test hyps) in + List.rev (map_succeed test (pf_hyps gl)) in let dephyps = List.map (fun (id,_,_) -> id) depdecls in (* Decides if x appears in conclusion *) let depconcl = occur_var (pf_env gl) x (pf_concl gl) in @@ -1373,23 +1431,47 @@ let subst_one dep_proof_ok x gl = (id,None,_) -> intro_using id | (id,Some hval,htyp) -> letin_tac None (Name id) - (replace_term varx rhs hval) - (Some (replace_term varx rhs htyp)) nowhere + (replace_term (mkVar x) rhs hval) + (Some (replace_term (mkVar x) rhs htyp)) nowhere in let need_rewrite = dephyps <> [] || depconcl in tclTHENLIST ((if need_rewrite then [generalize abshyps; - general_rewrite dir all_occurrences dep_proof_ok (mkVar hyp); + general_rewrite dir all_occurrences true dep_proof_ok (mkVar hyp); thin dephyps; tclMAP introtac depdecls] - else - [thin dephyps; - tclMAP introtac depdecls]) @ + else + [tclIDTAC]) @ [tclTRY (clear [x;hyp])]) gl +(* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite + it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) + +let subst_one_var dep_proof_ok x gl = + let hyps = pf_hyps gl in + let (_,xval,_) = pf_get_hyp gl x in + (* If x has a body, simply replace x with body and clear x *) + if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else + (* x is a variable: *) + let varx = mkVar x in + (* Find a non-recursive definition for x *) + let (hyp,rhs,dir) = + try + let test hyp _ = is_eq_x gl varx hyp in + Sign.fold_named_context test ~init:() hyps; + errorlabstrm "Subst" + (str "Cannot find any non-recursive equality over " ++ pr_id x ++ + str".") + with FoundHyp res -> res in + subst_one dep_proof_ok x (hyp,rhs,dir) gl + let subst_gen dep_proof_ok ids = - tclTHEN tclNORMEVAR (tclMAP (subst_one dep_proof_ok) ids) + tclTHEN tclNORMEVAR (tclMAP (subst_one_var dep_proof_ok) ids) + +(* For every x, look for an hypothesis hyp of the form "x=rhs" or "rhs=x", + rewrite it everywhere, and erase hyp and x; proceed by generalizing + all dep hyps *) let subst = subst_gen true @@ -1466,3 +1548,5 @@ let replace_multi_term dir_opt c = let _ = Tactics.register_general_multi_rewrite (fun b evars t cls -> general_multi_rewrite b evars t cls) + +let _ = Tactics.register_subst_one (fun b -> subst_one b) diff --git a/tactics/equality.mli b/tactics/equality.mli index 0c2d8942..79059469 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* occurrences -> dep_proof_flag -> + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic val general_rewrite : - orientation -> occurrences -> dep_proof_flag -> + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(tactic * conditions) -> constr -> tactic (* Equivalent to [general_rewrite l2r] *) @@ -56,15 +55,16 @@ val register_general_rewrite_clause : val register_is_applied_rewrite_relation : (env -> evar_map -> rel_context -> constr -> constr option) -> unit val general_rewrite_ebindings_clause : identifier option -> - orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) -> - constr with_bindings -> evars_flag -> tactic + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> + ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic val general_rewrite_bindings_in : - orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) -> + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> + ?tac:(tactic * conditions) -> identifier -> constr with_bindings -> evars_flag -> tactic val general_rewrite_in : - orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) -> - identifier -> constr -> evars_flag -> tactic + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> + ?tac:(tactic * conditions) -> identifier -> constr -> evars_flag -> tactic val general_multi_rewrite : orientation -> evars_flag -> ?tac:(tactic * conditions) -> constr with_bindings -> clause -> tactic @@ -73,7 +73,7 @@ type delayed_open_constr_with_bindings = env -> evar_map -> evar_map * constr with_bindings val general_multi_multi_rewrite : - evars_flag -> (bool * multi * delayed_open_constr_with_bindings) list -> + evars_flag -> (bool * multi * delayed_open_constr_with_bindings) list -> clause -> (tactic * conditions) option -> tactic val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 9f7c0a54..992fdc91 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* evar_list sigma gl.it.evar_concl + ConclLocation () -> evar_list sigma (pf_concl gl) | HypLocation (id,hloc) -> - let decl = Environ.lookup_named_val id gl.it.evar_hyps in + let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in match hloc with InHyp -> (match decl with @@ -57,4 +55,3 @@ let let_evar name typ gls = let sigma',evar = Evarutil.new_evar gls.sigma (pf_env gls) ~src typ in Refiner.tclTHEN (Refiner.tclEVARS sigma') (Tactics.letin_tac None name evar None nowhere) gls - diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli index f54f6a4c..882cf3ce 100644 --- a/tactics/evar_tactics.mli +++ b/tactics/evar_tactics.mli @@ -1,23 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tacinterp.interp_sign * Rawterm.rawconstr -> +val instantiate : int -> Tacinterp.interp_sign * Glob_term.glob_constr -> (identifier * hyp_location_flag, unit) location -> tactic -(*i -val instantiate_tac : tactic_arg list -> tactic -i*) - val let_evar : name -> Term.types -> tactic diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 310423d2..6a13ac2a 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.mt () | false -> Pp.str " <-" - ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient | [ "->" ] -> [ true ] | [ "<-" ] -> [ false ] | [ ] -> [ true ] END -let pr_int_list _prc _prlc _prt l = +let pr_orient = pr_orient () () () + +let pr_int_list_full _prc _prlc _prt l = let rec aux = function | i :: l -> Pp.int i ++ Pp.spc () ++ aux l | [] -> Pp.mt() in aux l ARGUMENT EXTEND int_nelist - TYPED AS int list - PRINTED BY pr_int_list + PRINTED BY pr_int_list_full RAW_TYPED AS int list - RAW_PRINTED BY pr_int_list + RAW_PRINTED BY pr_int_list_full GLOB_TYPED AS int list - GLOB_PRINTED BY pr_int_list + GLOB_PRINTED BY pr_int_list_full | [ integer(x) int_nelist(l) ] -> [x::l] | [ integer(x) ] -> [ [x] ] END -open Rawterm +let pr_int_list = pr_int_list_full () () () + +open Glob_term let pr_occurrences _prc _prlc _prt l = match l with - | ArgArg x -> pr_int_list _prc _prlc _prt x + | ArgArg x -> pr_int_list x | ArgVar (loc, id) -> Nameops.pr_id id let coerce_to_int = function @@ -81,8 +81,7 @@ type occurrences_or_var = int list or_var type occurrences = int list ARGUMENT EXTEND occurrences - TYPED AS occurrences - PRINTED BY pr_int_list + PRINTED BY pr_int_list_full INTERPRETED BY interp_occs GLOBALIZED BY glob_occs @@ -98,32 +97,34 @@ ARGUMENT EXTEND occurrences | [ var(id) ] -> [ ArgVar id ] END +let pr_occurrences = pr_occurrences () () () + let pr_gen prc _prlc _prtac c = prc c -let pr_rawc _prc _prlc _prtac (_,raw) = Printer.pr_rawconstr raw +let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob -let interp_raw ist gl (t,_) = (ist,t) +let interp_glob ist gl (t,_) = (ist,t) -let glob_raw = Tacinterp.intern_constr +let glob_glob = Tacinterp.intern_constr -let subst_raw = Tacinterp.subst_rawconstr_and_expr +let subst_glob = Tacinterp.subst_glob_constr_and_expr -ARGUMENT EXTEND raw - TYPED AS rawconstr - PRINTED BY pr_rawc +ARGUMENT EXTEND glob + PRINTED BY pr_globc - INTERPRETED BY interp_raw - GLOBALIZED BY glob_raw - SUBSTITUTED BY subst_raw + INTERPRETED BY interp_glob + GLOBALIZED BY glob_glob + SUBSTITUTED BY subst_glob RAW_TYPED AS constr_expr RAW_PRINTED BY pr_gen - GLOB_TYPED AS rawconstr_and_expr + GLOB_TYPED AS glob_constr_and_expr GLOB_PRINTED BY pr_gen [ lconstr(c) ] -> [ c ] END + type 'id gen_place= ('id * hyp_location_flag,unit) location type loc_place = identifier Util.located gen_place @@ -139,6 +140,7 @@ let pr_gen_place pr_id = function let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id) let pr_place _ _ _ = pr_gen_place Nameops.pr_id +let pr_hloc = pr_loc_place () () () let intern_place ist = function ConclLocation () -> ConclLocation () @@ -151,7 +153,6 @@ let interp_place ist gl = function let subst_place subst pl = pl ARGUMENT EXTEND hloc - TYPED AS place PRINTED BY pr_place INTERPRETED BY interp_place GLOBALIZED BY intern_place @@ -193,6 +194,7 @@ ARGUMENT EXTEND by_arg_tac | [ ] -> [ None ] END +let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c let pr_in_hyp pr_id (lo,concl) : Pp.std_ppcmds = match lo,concl with @@ -220,7 +222,6 @@ let pr_var_list _ _ _ = pr_var_list_gen (fun (_,id) -> Ppconstr.pr_id id) ARGUMENT EXTEND comma_var_lne - TYPED AS var list PRINTED BY pr_var_list_typed RAW_TYPED AS var list RAW_PRINTED BY pr_var_list @@ -231,7 +232,6 @@ ARGUMENT EXTEND comma_var_lne END ARGUMENT EXTEND comma_var_l - TYPED AS var list PRINTED BY pr_var_list_typed RAW_TYPED AS var list RAW_PRINTED BY pr_var_list @@ -253,7 +253,6 @@ END ARGUMENT EXTEND in_arg_hyp - TYPED AS var list option * bool PRINTED BY pr_in_arg_hyp_typed RAW_TYPED AS var list option * bool RAW_PRINTED BY pr_in_arg_hyp @@ -267,6 +266,7 @@ ARGUMENT EXTEND in_arg_hyp | [ ] -> [ (Some [],true) ] END +let pr_in_arg_hyp = pr_in_arg_hyp_typed () () () let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = {Tacexpr.onhyps= diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index a3f27fde..2abca40e 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -1,32 +1,32 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds -val occurrences : (int list or_var) Pcoq.Gram.Entry.e +val occurrences : (int list or_var) Pcoq.Gram.entry val rawwit_occurrences : (int list or_var) raw_abstract_argument_type val wit_occurrences : (int list) typed_abstract_argument_type +val pr_occurrences : int list Glob_term.or_var -> Pp.std_ppcmds -val rawwit_raw : constr_expr raw_abstract_argument_type -val wit_raw : (Tacinterp.interp_sign * rawconstr) typed_abstract_argument_type -val raw : constr_expr Pcoq.Gram.Entry.e +val rawwit_glob : constr_expr raw_abstract_argument_type +val wit_glob : (Tacinterp.interp_sign * glob_constr) typed_abstract_argument_type +val glob : constr_expr Pcoq.Gram.entry type 'id gen_place= ('id * hyp_location_flag,unit) location @@ -35,24 +35,26 @@ type place = identifier gen_place val rawwit_hloc : loc_place raw_abstract_argument_type val wit_hloc : place typed_abstract_argument_type -val hloc : loc_place Pcoq.Gram.Entry.e - +val hloc : loc_place Pcoq.Gram.entry +val pr_hloc : loc_place -> Pp.std_ppcmds -val in_arg_hyp: (Names.identifier Util.located list option * bool) Pcoq.Gram.Entry.e +val in_arg_hyp: (Names.identifier Util.located list option * bool) Pcoq.Gram.entry val rawwit_in_arg_hyp : (Names.identifier Util.located list option * bool) raw_abstract_argument_type val wit_in_arg_hyp : (Names.identifier list option * bool) typed_abstract_argument_type val raw_in_arg_hyp_to_clause : (Names.identifier Util.located list option * bool) -> Tacticals.clause val glob_in_arg_hyp_to_clause : (Names.identifier list option * bool) -> Tacticals.clause +val pr_in_arg_hyp : (Names.identifier list option * bool) -> Pp.std_ppcmds - -val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.Entry.e +val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry val rawwit_by_arg_tac : raw_tactic_expr option raw_abstract_argument_type val wit_by_arg_tac : glob_tactic_expr option typed_abstract_argument_type +val pr_by_arg_tac : + (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> + raw_tactic_expr option -> Pp.std_ppcmds +(** Spiwack: Primitive for retroknowledge registration *) -(* Spiwack: Primitive for retroknowledge registration *) - -val retroknowledge_field : Retroknowledge.field Pcoq.Gram.Entry.e +val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry val rawwit_retroknowledge_field : Retroknowledge.field raw_abstract_argument_type val wit_retroknowledge_field : Retroknowledge.field typed_abstract_argument_type diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index c4a2ef44..da35edbe 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.mt () + | false -> Pp.str " <-" + +let pr_orient_string _prc _prlc _prt (orient, s) = + pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s + +ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string +| [ orient(r) preident(i) ] -> [ r, i ] +END + TACTIC EXTEND autorewrite | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) ] -> [ auto_multi_rewrite l (glob_in_arg_hyp_to_clause cl) ] | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] -> [ let cl = glob_in_arg_hyp_to_clause cl in - auto_multi_rewrite_with (snd t) l cl + auto_multi_rewrite_with (Tacinterp.eval_tactic t) l cl ] END @@ -205,7 +214,7 @@ TACTIC EXTEND autorewrite_star [ auto_multi_rewrite ~conds:AllMatches l (glob_in_arg_hyp_to_clause cl) ] | [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] -> [ let cl = glob_in_arg_hyp_to_clause cl in - auto_multi_rewrite_with ~conds:AllMatches (snd t) l cl ] + auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.eval_tactic t) l cl ] END (**********************************************************************) @@ -214,7 +223,7 @@ END let rewrite_star clause orient occs (sigma,c) (tac : glob_tactic_expr option) = let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in Refiner. tclWITHHOLES false - (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true (c,NoBindings)) sigma true + (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings)) sigma true let occurrences_of = function | n::_ as nl when n < 0 -> (false,List.map abs nl) @@ -229,11 +238,11 @@ TACTIC EXTEND rewrite_star | [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> [ rewrite_star (Some id) o (occurrences_of occ) c tac ] | [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star (Some id) o all_occurrences c tac ] + [ rewrite_star (Some id) o Termops.all_occurrences c tac ] | [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> [ rewrite_star None o (occurrences_of occ) c tac ] | [ "rewrite" "*" orient(o) open_constr(c) by_arg_tac(tac) ] -> - [ rewrite_star None o all_occurrences c tac ] + [ rewrite_star None o Termops.all_occurrences c tac ] END (**********************************************************************) @@ -277,7 +286,7 @@ let project_hint pri l2r c = 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,c) + (pri,true,Auto.PathAny,c) let add_hints_iff l2r lc n bl = Auto.add_hints true bl @@ -326,18 +335,18 @@ VERNAC COMMAND EXTEND DeriveInversionClear -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] - -> [ add_inversion_lemma_exn na c (Rawterm.RProp Term.Null) false inv_clear_tac ] + -> [ add_inversion_lemma_exn na c (Glob_term.GProp Term.Null) false inv_clear_tac ] END open Term -open Rawterm +open Glob_term VERNAC COMMAND EXTEND DeriveInversion | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] -> [ add_inversion_lemma_exn na c s false inv_tac ] | [ "Derive" "Inversion" ident(na) "with" constr(c) ] - -> [ add_inversion_lemma_exn na c (RProp Null) false inv_tac ] + -> [ add_inversion_lemma_exn na c (GProp Null) false inv_tac ] | [ "Derive" "Inversion" ident(na) hyp(id) ] -> [ inversion_lemma_from_goal 1 na id Term.prop_sort false inv_tac ] @@ -385,7 +394,7 @@ open Tacexpr open Tacticals TACTIC EXTEND instantiate - [ "instantiate" "(" integer(i) ":=" raw(c) ")" hloc(hl) ] -> + [ "instantiate" "(" integer(i) ":=" glob(c) ")" hloc(hl) ] -> [instantiate i c hl ] | [ "instantiate" ] -> [ tclNORMEVAR ] END @@ -397,7 +406,7 @@ END open Tactics open Tactics open Libnames -open Rawterm +open Glob_term open Summary open Libobject open Lib @@ -433,7 +442,7 @@ let cache_transitivity_lemma (_,(left,lem)) = let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) -let (inTransitivity,_) = +let inTransitivity : bool * constr -> obj = declare_object {(default_object "TRANSITIVITY-STEPS") with cache_function = cache_transitivity_lemma; open_function = (fun i o -> if i=1 then cache_transitivity_lemma o); @@ -467,12 +476,12 @@ let add_transitivity_lemma left lem = (* Vernacular syntax *) TACTIC EXTEND stepl -| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (snd tac) ] +| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.eval_tactic tac) ] | ["stepl" constr(c) ] -> [ step true c tclIDTAC ] END TACTIC EXTEND stepr -| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (snd tac) ] +| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.eval_tactic tac) ] | ["stepr" constr(c) ] -> [ step false c tclIDTAC ] END @@ -488,7 +497,7 @@ END VERNAC COMMAND EXTEND ImplicitTactic | [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> - [ Tacinterp.declare_implicit_tactic (Tacinterp.interp tac) ] + [ Pfedit.declare_implicit_tactic (Tacinterp.interp tac) ] END @@ -539,27 +548,27 @@ END (**********************************************************************) let subst_var_with_hole occ tid t = - let occref = if occ > 0 then ref occ else error_invalid_occurrence [occ] in + let occref = if occ > 0 then ref occ else Termops.error_invalid_occurrence [occ] in let locref = ref 0 in let rec substrec = function - | RVar (_,id) as x -> + | GVar (_,id) as x -> if id = tid then (decr occref; if !occref = 0 then x - else (incr locref; RHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true)))) + else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true)))) else x - | c -> map_rawconstr_left_to_right substrec c in + | c -> map_glob_constr_left_to_right substrec c in let t' = substrec t in - if !occref > 0 then error_invalid_occurrence [occ] else t' + if !occref > 0 then Termops.error_invalid_occurrence [occ] else t' let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in let rec substrec = function - | RHole (_,Evd.QuestionMark(Evd.Define true)) -> + | GHole (_,Evd.QuestionMark(Evd.Define true)) -> decr occref; if !occref = 0 then tc - else (incr locref; RHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true))) - | c -> map_rawconstr_left_to_right substrec c + else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true))) + | c -> map_glob_constr_left_to_right substrec c in substrec t @@ -571,16 +580,16 @@ let out_arg = function let hResolve id c occ t gl = let sigma = project gl in - let env = clear_named_body id (pf_env gl) in - let env_ids = ids_of_context env in - let env_names = names_of_rel_context env in + let env = Termops.clear_named_body id (pf_env gl) in + let env_ids = Termops.ids_of_context env in + let env_names = Termops.names_of_rel_context env in let c_raw = Detyping.detype true env_ids env_names c in let t_raw = Detyping.detype true env_ids env_names t in let rec resolve_hole t_hole = try Pretyping.Default.understand sigma env t_hole with - | Stdpp.Exc_located (loc,Pretype_errors.PretypeError (_, Pretype_errors.UnsolvableImplicit _)) -> + | Loc.Exc_located (loc,Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _)) -> resolve_hole (subst_hole_with_term (fst (unloc loc)) c_raw t_hole) in let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in @@ -625,8 +634,91 @@ END (**********************************************************************) +(**********************************************************************) +(* A tactic that reduces one match t with ... by doing destruct t. *) +(* if t is not a variable, the tactic does *) +(* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is *) +(* preserved). *) +(* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) +(**********************************************************************) + +exception Found of tactic + +let rewrite_except h g = + tclMAP (fun id -> if id = h then tclIDTAC else + tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true true id (mkVar h) false)) + (Tacmach.pf_ids_of_hyps g) g + + +let refl_equal = + let coq_base_constant s = + Coqlib.gen_constant_in_modules "RecursiveDefinition" + (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in + function () -> (coq_base_constant "eq_refl") + + +(* This is simply an implementation of the case_eq tactic. this code + should be replaced by a call to the tactic but I don't know how to + call it before it is defined. *) +let mkCaseEq a : tactic = + (fun g -> + let type_of_a = Tacmach.pf_type_of g a in + tclTHENLIST + [Hiddentac.h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; + (fun g2 -> + change_in_concl None + (Tacred.pattern_occs [((false,[1]), a)] (Tacmach.pf_env g2) Evd.empty (Tacmach.pf_concl g2)) + g2); + simplest_case a] g);; + + +let case_eq_intros_rewrite x g = + let n = nb_prod (Tacmach.pf_concl g) in + Pp.msgnl (Printer.pr_lconstr x); + tclTHENLIST [ + mkCaseEq x; + (fun g -> + let n' = nb_prod (Tacmach.pf_concl g) in + let h = fresh_id (Tacmach.pf_ids_of_hyps g) (id_of_string "heq") g in + tclTHENLIST [ (tclDO (n'-n-1) intro); + Tacmach.introduction h; + rewrite_except h] g + ) + ] g + +let rec find_a_destructable_match t = + match kind_of_term t with + | Case (_,_,x,_) when closed0 x -> + if isVar x then + (* TODO check there is no rel n. *) + raise (Found (Tacinterp.eval_tactic(<:tactic>))) + else + let _ = Pp.msgnl (Printer.pr_lconstr x) in + raise (Found (case_eq_intros_rewrite x)) + | _ -> iter_constr find_a_destructable_match t + + +let destauto t = + try find_a_destructable_match t; + error "No destructable match found" + with Found tac -> tac + +let destauto_in id g = + let ctype = Tacmach.pf_type_of g (mkVar id) in + Pp.msgnl (Printer.pr_lconstr (mkVar id)); + Pp.msgnl (Printer.pr_lconstr (ctype)); + destauto ctype g + +TACTIC EXTEND destauto +| [ "destauto" ] -> [ (fun g -> destauto (Tacmach.pf_concl g) g) ] +| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] +END + + +(* ********************************************************************* *) + TACTIC EXTEND constr_eq -| [ "constr_eq" constr(x) constr(y) ] -> [ +| [ "constr_eq" constr(x) constr(y) ] -> [ if eq_constr x y then tclIDTAC else tclFAIL 0 (str "Not equal") ] END diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli index ecad939c..66f46722 100644 --- a/tactics/extratactics.mli +++ b/tactics/extratactics.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* tactic diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml index 018bf815..fafc681a 100644 --- a/tactics/hiddentac.ml +++ b/tactics/hiddentac.ml @@ -1,18 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ElimOnConstr c + | ElimOnIdent id -> ElimOnIdent id + | ElimOnAnonHyp n -> ElimOnAnonHyp n + let h_induction_destruct isrec ev lcl = - abstract_tactic (TacInductionDestruct (isrec,ev,lcl)) + let lcl' = on_fst (List.map (fun (a,b,c) ->(List.map out_indarg a,b,c))) lcl in + abstract_tactic (TacInductionDestruct (isrec,ev,lcl')) (induction_destruct isrec ev lcl) -let h_new_induction ev c e idl cl = h_induction_destruct true ev ([c,e,idl],cl) +let h_new_induction ev c e idl cl = + h_induction_destruct true ev ([c,e,idl],cl) let h_new_destruct ev c e idl cl = h_induction_destruct false ev ([c,e,idl],cl) let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (specialize n d) @@ -102,9 +111,9 @@ let h_any_constructor t = abstract_tactic (TacAnyConstructor t) (any_constructor t) *) let h_constructor ev n l = - abstract_tactic (TacConstructor(ev,AI n,l))(constructor_tac ev None n l) + abstract_tactic (TacConstructor(ev,ArgArg n,l))(constructor_tac ev None n l) let h_one_constructor n = - abstract_tactic (TacConstructor(false,AI n,NoBindings)) (one_constructor n NoBindings) + abstract_tactic (TacConstructor(false,ArgArg n,NoBindings)) (one_constructor n NoBindings) let h_simplest_left = h_left false NoBindings let h_simplest_right = h_right false NoBindings diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli index 31484cc0..96e7e3f0 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* identifier move_location -> tactic val h_intro : identifier -> tactic @@ -61,39 +57,44 @@ val h_generalize_gen : (constr with_occurrences * name) list -> tactic val h_generalize_dep : constr -> tactic val h_let_tac : letin_flag -> name -> constr -> Tacticals.clause -> tactic +val h_let_pat_tac : letin_flag -> name -> evar_map * constr -> + Tacticals.clause -> tactic -(* Derived basic tactics *) +(** Derived basic tactics *) val h_simple_induction : quantified_hypothesis -> tactic val h_simple_destruct : quantified_hypothesis -> tactic val h_simple_induction_destruct : rec_flag -> quantified_hypothesis -> tactic val h_new_induction : evars_flag -> - constr with_bindings induction_arg list -> constr with_bindings option -> + (evar_map * constr with_bindings) induction_arg list -> + constr with_bindings option -> intro_pattern_expr located option * intro_pattern_expr located option -> Tacticals.clause option -> tactic val h_new_destruct : evars_flag -> - constr with_bindings induction_arg list -> constr with_bindings option -> + (evar_map * constr with_bindings) induction_arg list -> + constr with_bindings option -> intro_pattern_expr located option * intro_pattern_expr located option -> Tacticals.clause option -> tactic val h_induction_destruct : rec_flag -> evars_flag -> - (constr with_bindings induction_arg list * constr with_bindings option * + ((evar_map * constr with_bindings) induction_arg list * + constr with_bindings option * (intro_pattern_expr located option * intro_pattern_expr located option)) list * Tacticals.clause option -> tactic val h_specialize : int option -> constr with_bindings -> tactic val h_lapply : constr -> tactic -(* Automation tactic : see Auto *) +(** Automation tactic : see Auto *) -(* Context management *) +(** Context management *) val h_clear : bool -> identifier list -> tactic val h_clear_body : identifier list -> tactic val h_move : bool -> identifier -> identifier move_location -> tactic val h_rename : (identifier*identifier) list -> tactic val h_revert : identifier list -> tactic -(* Constructors *) +(** Constructors *) val h_constructor : evars_flag -> int -> constr bindings -> tactic val h_left : evars_flag -> constr bindings -> tactic val h_right : evars_flag -> constr bindings -> tactic @@ -104,12 +105,12 @@ val h_simplest_left : tactic val h_simplest_right : tactic -(* Conversion *) +(** Conversion *) val h_reduce : Redexpr.red_expr -> Tacticals.clause -> tactic val h_change : Pattern.constr_pattern option -> constr -> Tacticals.clause -> tactic -(* Equivalence relations *) +(** Equivalence relations *) val h_reflexivity : tactic val h_symmetry : Tacticals.clause -> tactic val h_transitivity : constr option -> tactic diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 08bcf65a..9057c60d 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* b=None && c = mkRel mib.mind_nparams) ctx + (fun (_,b,c) -> b=None && isRel c && destRel c = mib.mind_nparams) ctx then Some (hdapp,args) else None @@ -145,7 +142,7 @@ let is_tuple t = let test_strict_disjunction n lc = array_for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with - | [_,None,c] -> c = mkRel (n - i) + | [_,None,c] -> isRel c && destRel c = (n - i) | _ -> false) 0 lc let match_with_disjunction ?(strict=false) t = @@ -426,6 +423,7 @@ let dest_nf_eq gls eqn = (* Patterns "(existS ?1 ?2 ?3 ?4)" and "(existT ?1 ?2 ?3 ?4)" *) 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 matches (Lazy.force ex_pat) ex with @@ -437,7 +435,8 @@ let match_sigma ex ex_pat = let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) first_match (match_sigma ex) - [coq_existT_pattern, build_sigma_type] + [coq_existT_pattern, build_sigma_type; + coq_exist_pattern, build_sigma] (* Pattern "(sig ?1 ?2)" *) let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ] diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 15d7bfc6..aa386364 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -1,25 +1,22 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool val match_with_non_recursive_type : (constr * constr list) matching_function val is_non_recursive_type : testing_function -(* Non recursive type with no indices and exactly one argument for each +(** Non recursive type with no indices and exactly one argument for each constructor; canonical definition of n-ary disjunction if strict *) val match_with_disjunction : ?strict:bool -> (constr * constr list) matching_function val is_disjunction : ?strict:bool -> testing_function -(* Non recursive tuple (one constructor and no indices) with no inner +(** Non recursive tuple (one constructor and no indices) with no inner dependencies; canonical definition of n-ary conjunction if strict *) val match_with_conjunction : ?strict:bool -> (constr * constr list) matching_function val is_conjunction : ?strict:bool -> testing_function -(* Non recursive tuple, possibly with inner dependencies *) +(** Non recursive tuple, possibly with inner dependencies *) val match_with_record : (constr * constr list) matching_function val is_record : testing_function -(* Like record but supports and tells if recursive (e.g. Acc) *) +(** Like record but supports and tells if recursive (e.g. Acc) *) val match_with_tuple : (constr * constr list * bool) matching_function val is_tuple : testing_function -(* No constructor, possibly with indices *) +(** No constructor, possibly with indices *) val match_with_empty_type : constr matching_function val is_empty_type : testing_function -(* type with only one constructor and no arguments, possibly with indices *) +(** type with only one constructor and no arguments, possibly with indices *) val match_with_unit_or_eq_type : constr matching_function val is_unit_or_eq_type : testing_function -(* type with only one constructor and no arguments, no indices *) +(** type with only one constructor and no arguments, no indices *) val is_unit_type : testing_function -(* type with only one constructor, no arguments and at least one dependency *) +(** type with only one constructor, no arguments and at least one dependency *) val is_inductive_equality : inductive -> bool val match_with_equality_type : (constr * constr list) matching_function val is_equality_type : testing_function @@ -96,7 +93,7 @@ val is_forall_term : testing_function val match_with_imp_term : (constr * constr) matching_function val is_imp_term : testing_function -(* I added these functions to test whether a type contains dependent +(** I added these functions to test whether a type contains dependent products or not, and if an inductive has constructors with dependent types (excluding parameters). this is useful to check whether a conjunction is a real conjunction and not a dependent tuple. (Pierre Corbineau, 13/5/2002) *) @@ -110,7 +107,7 @@ val is_nodep_ind : testing_function val match_with_sigma_type : (constr * constr list) matching_function val is_sigma_type : testing_function -(* Recongnize inductive relation defined by reflexivity *) +(** Recongnize inductive relation defined by reflexivity *) type equation_kind = | MonomorphicLeibnizEq of constr * constr @@ -124,37 +121,37 @@ val match_with_equation: (***** Destructing patterns bound to some theory *) -(* 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 *) +(** 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 : Proof_type.goal sigma -> constr -> coq_eq_data * (types * constr * constr) -(* Idem but fails with an error message instead of PatternMatchingFailure *) +(** Idem but fails with an error message instead of PatternMatchingFailure *) val find_this_eq_data_decompose : Proof_type.goal sigma -> constr -> coq_eq_data * (types * constr * constr) -(* A variant that returns more informative structure on the equality found *) +(** A variant that returns more informative structure on the equality found *) val find_eq_data : constr -> coq_eq_data * equation_kind -(* Match a term of the form [(existT A P t p)] *) -(* Returns associated lemmas and [A,P,t,p] *) +(** 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) -(* Match a term of the form [{x:A|P}], returns [A] and [P] *) +(** Match a term of the form [{x:A|P}], returns [A] and [P] *) val match_sigma : constr -> constr * constr val is_matching_sigma : constr -> bool -(* Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns +(** Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns [t,u,T] and a boolean telling if equality is on the left side *) val match_eqdec : constr -> bool * constr * constr * constr * constr -(* Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) +(** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) open Proof_type open Tacmach val dest_nf_eq : goal sigma -> constr -> (constr * constr * constr) -(* Match a negation *) +(** Match a negation *) val is_matching_not : constr -> bool val is_matching_imp_False : constr -> bool diff --git a/tactics/inv.ml b/tactics/inv.ml index 37142f30..2ae4e22e 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* dEqThen false (deq_trailer id) (Some (ElimOnIdent (dummy_loc,id)))) + (fun id -> + dEqThen false (deq_trailer id) + (Some (ElimOnConstr (mkVar id,NoBindings)))) id gls diff --git a/tactics/inv.mli b/tactics/inv.mli index 43e2a8de..ef828d88 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -1,22 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - if List.mem id globs then - match c with - | None -> (id::ids,(global_vars env a)@globs) - | Some body -> - (id::ids,(global_vars env body)@(global_vars env a)@globs) - else sofar) - ([],vars) hyps) - (* returns the sub_signature of sign corresponding to those identifiers that * are not global. *) (* @@ -192,10 +175,6 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let extenv = push_named (p,None,npty) env in extenv, goal -let whd_meta_from_map metamap c = match kind_of_term c with - | Meta p -> (try List.assoc p metamap with Not_found -> c) - | _ -> c - (* [inversion_scheme sign I] Given a local signature, [sign], and an instance of an inductive @@ -221,29 +200,32 @@ 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 invSign = named_context_val invEnv in - let pfs = mk_pftreestate (mk_goal invSign invGoal None) in - let pfs = solve_pftreestate (tclTHEN intro (onLastHypId inv_op)) pfs in - let (pfterm,meta_types) = extract_open_pftreestate pfs in + let pf = Proof.start [invEnv,invGoal] in + Proof.run_tactic env (Proofview.V82.tactic (tclTHEN intro (onLastHypId inv_op))) pf; + let pfterm = List.hd (Proof.partial_proof pf) in let global_named_context = Global.named_context () in - let ownSign = + let ownSign = ref begin fold_named_context (fun env (id,_,_ as d) sign -> if mem_named_context id global_named_context then sign else add_named_decl d sign) invEnv ~init:empty_named_context + end in + let avoid = ref [] in + let { sigma=sigma } = Proof.V82.subgoals pf in + let rec fill_holes c = + match kind_of_term c with + | Evar (e,args) -> + let h = next_ident_away (id_of_string "H") !avoid in + let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in + avoid := h::!avoid; + ownSign := add_named_decl (h,None,ty) !ownSign; + applist (mkVar h, inst) + | _ -> map_constr fill_holes c in - let (_,ownSign,mvb) = - List.fold_left - (fun (avoid,sign,mvb) (mv,mvty) -> - let h = next_ident_away (id_of_string "H") avoid in - (h::avoid, add_named_decl (h,None,mvty) sign, (mv,mkVar h)::mvb)) - (ids_of_context invEnv, ownSign, []) - meta_types - in - let invProof = - it_mkNamedLambda_or_LetIn - (local_strong (fun _ -> whd_meta_from_map mvb) Evd.empty pfterm) ownSign + let c = fill_holes pfterm in + (* warning: side-effect on ownSign *) + let invProof = it_mkNamedLambda_or_LetIn c !ownSign in invProof @@ -253,32 +235,23 @@ let add_inversion_lemma name env sigma t sort dep inv_op = declare_constant name (DefinitionEntry { const_entry_body = invProof; + const_entry_secctx = None; const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = true && (Flags.boxed_definitions())}, + const_entry_opaque = false }, IsProof Lemma) in () -(* open Pfedit *) - (* inv_op = Inv (derives de complete inv. lemma) * inv_op = InvNoThining (derives de semi inversion lemma) *) let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op = let pts = get_pftreestate() in - let gl = nth_goal_of_pftreestate n pts in + let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in + let gl = { it = List.nth gls (n-1) ; sigma=sigma } in let t = try pf_get_hyp_typ gl id with Not_found -> Pretype_errors.error_var_not_found_loc loc id in let env = pf_env gl and sigma = project gl in -(* Pourquoi ??? - let fv = global_vars env t in - let thin_ids = thin_ids (hyps,fv) in - if not(list_subset thin_ids fv) then - errorlabstrm "lemma_inversion" - (str"Cannot compute lemma inversion when there are" ++ spc () ++ - str"free variables in the types of an inductive" ++ spc () ++ - str"which are not free in its instance."); *) add_inversion_lemma na env sigma t sort dep_option inv_op let add_inversion_lemma_exn na com comsort bool tac = @@ -296,11 +269,10 @@ let add_inversion_lemma_exn na com comsort bool tac = (* ================================= *) let lemInv id c gls = - ignore (pf_get_hyp gls id); (* ensure id exists *) try let clause = mk_clenv_type_of gls c in let clause = clenv_constrain_last_binding (mkVar id) clause in - Clenvtac.res_pf clause ~allow_K:true gls + Clenvtac.res_pf clause ~flags:Unification.elim_flags gls with | NoSuchBinding -> errorlabstrm "" diff --git a/tactics/leminv.mli b/tactics/leminv.mli index b4b5737b..233aeba3 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -1,7 +1,7 @@ open Util open Names open Term -open Rawterm +open Glob_term open Proof_type open Topconstr @@ -15,5 +15,5 @@ val inversion_lemma_from_goal : int -> identifier -> identifier located -> sorts -> bool -> (identifier -> tactic) -> unit val add_inversion_lemma_exn : - identifier -> constr_expr -> rawsort -> bool -> (identifier -> tactic) -> + identifier -> constr_expr -> glob_sort -> bool -> (identifier -> tactic) -> unit diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml index 19df4ff1..4e34fae8 100644 --- a/tactics/nbtermdn.ml +++ b/tactics/nbtermdn.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* sig diff --git a/tactics/refine.ml b/tactics/refine.ml index c1b1fe9d..e7f3998a 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* invalid_arg "Tcc.replace_by_meta (TO DO)" *) in - if occur_meta ty then - error "Unable to manage a dependent metavariable of higher-order type."; mkCast (m,DEFAULTcast, ty),[n,ty],[Some th] exception NoMeta @@ -197,8 +193,6 @@ let rec compute_metamap env sigma c = match kind_of_term c with end | Case (ci,p,cc,v) -> - if occur_meta p then - error "Unable to manage a metavariable in the return clause of a match."; (* bof... *) let nbr = Array.length v in let v = Array.append [|p;cc|] v in @@ -401,5 +395,3 @@ let refine (evd,c) gl = complicated to update meta types when passing through a binder *) let th = compute_metamap (pf_env gl) evd c in tclTHEN (Refiner.tclEVARS evd) (tcc_aux [] th) gl - -let _ = Decl_proof_instr.set_refine refine (* dirty trick to solve circular dependency *) diff --git a/tactics/refine.mli b/tactics/refine.mli index 15491616..a96f47ba 100644 --- a/tactics/refine.mli +++ b/tactics/refine.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* tactic diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 index fd3eeeb2..d297969d 100644 --- a/tactics/rewrite.ml4 +++ b/tactics/rewrite.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* hd, tl | [] -> assert(false) -let new_goal_evar (goal,cstr) env t = - let goal', t = Evarutil.new_evar goal env t in - (goal', cstr), t - let new_cstr_evar (goal,cstr) env t = let cstr', t = Evarutil.new_evar cstr env t in (goal, cstr'), t +let new_goal_evar (goal,cstr) env t = + let goal', t = Evarutil.new_evar goal env t in + (goal', cstr), t + let build_signature evars env m (cstrs : (types * types option) option list) (finalcstr : (types * types option) option) = let new_evar evars env t = @@ -220,11 +189,17 @@ 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 +let extends_undefined evars evars' = + let f ev evi found = found || not (Evd.mem evars ev) + in fold_undefined f evars' false + + 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 - mkApp (Lazy.force proof_method, [| carrier; relation; c |]) + 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 |]) with e when Logic.catchable_exception e -> raise Not_found let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env @@ -247,10 +222,14 @@ type hypinfo = { l2r : bool; c1 : constr; c2 : constr; - c : constr with_bindings option; + c : (Tacinterp.interp_sign * Genarg.glob_constr_and_expr with_bindings) option; abs : (constr * types) option; + flags : Unification.unify_flags; } +let goalevars evars = fst evars +let cstrevars evars = snd evars + let evd_convertible env evd x y = try ignore(Evarconv.the_conv_x env x y evd); true with _ -> false @@ -270,10 +249,14 @@ 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 (c,l) left2right = - let ctype = Typing.type_of env sigma c in +(* let nc, c', cl = push_rel_context_to_named_context env c in *) +(* let env' = reset_with_named_context nc env in *) + +let decompose_applied_relation env 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 sigma (Clenv.clenv_type eqclause) in let c1 = args.(0) and c2 = args.(1) in let ty1, ty2 = @@ -283,7 +266,8 @@ let decompose_applied_relation env sigma (c,l) left2right = else Some { cl=eqclause; prf=(Clenv.clenv_value eqclause); car=ty1; rel = equiv; - l2r=left2right; c1=c1; c2=c2; c=Some (c,l); abs=None } + l2r=left2right; c1=c1; c2=c2; c=orig; abs=None; + flags = flags } in match find_rel ctype with | Some c -> c @@ -293,44 +277,81 @@ let decompose_applied_relation env sigma (c,l) left2right = | Some c -> c | None -> error "The term does not end with an applied homogeneous relation." -let rewrite_unif_flags = { - Unification.modulo_conv_on_closed_terms = None; - Unification.use_metas_eagerly = true; - Unification.modulo_delta = empty_transparent_state; - Unification.resolve_evars = true; - Unification.use_evars_pattern_unification = true; -} +open Tacinterp +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 flags (Some (is, (c,l))) cbl left2right + +let rewrite_db = "rewrite" let conv_transparent_state = (Idpred.empty, Cpred.full) -let rewrite2_unif_flags = { - Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; - Unification.use_metas_eagerly = true; +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) + +let rewrite_unif_flags = { + Unification.modulo_conv_on_closed_terms = None; + Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; + Unification.modulo_delta_types = full_transparent_state; + Unification.check_applied_meta_types = true; Unification.resolve_evars = true; - Unification.use_evars_pattern_unification = true; + Unification.use_pattern_unification = true; + Unification.use_meta_bound_pattern_unification = true; + Unification.frozen_evars = ExistentialSet.empty; + Unification.restrict_conv_on_strict_subterms = false; + Unification.modulo_betaiota = false; + Unification.modulo_eta = true; + Unification.allow_K_in_toplevel_higher_order_unification = true } -let setoid_rewrite_unif_flags = { - Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; - Unification.use_metas_eagerly = true; - Unification.modulo_delta = conv_transparent_state; - Unification.resolve_evars = true; - Unification.use_evars_pattern_unification = true; -} +let rewrite2_unif_flags = + { 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 = conv_transparent_state; + Unification.check_applied_meta_types = true; + Unification.resolve_evars = true; + Unification.use_pattern_unification = true; + Unification.use_meta_bound_pattern_unification = true; + Unification.frozen_evars = ExistentialSet.empty; + Unification.restrict_conv_on_strict_subterms = false; + Unification.modulo_betaiota = true; + Unification.modulo_eta = true; + Unification.allow_K_in_toplevel_higher_order_unification = true + } + +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; + Unification.modulo_delta = ts; + Unification.modulo_delta_types = ts; + Unification.check_applied_meta_types = true; + Unification.resolve_evars = true; + Unification.use_pattern_unification = true; + Unification.use_meta_bound_pattern_unification = true; + Unification.frozen_evars = ExistentialSet.empty; + Unification.restrict_conv_on_strict_subterms = false; + Unification.modulo_betaiota = true; + Unification.modulo_eta = true; + Unification.allow_K_in_toplevel_higher_order_unification = true } let convertible env evd x y = Reductionops.is_conv env evd x y -let allowK = true - let refresh_hypinfo env sigma hypinfo = if hypinfo.abs = None then - let {l2r=l2r; c=c;cl=cl} = hypinfo in + 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 env cl.evd c l2r; + decompose_applied_relation_expr env sigma flags c l2r; | _ -> hypinfo else hypinfo @@ -342,19 +363,13 @@ let unify_eqn env sigma hypinfo t = let env', prf, c1, c2, car, rel = match abs with | Some (absprf, absprfty) -> - let env' = clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl in + let env' = clenv_unify ~flags:rewrite_unif_flags CONV left t cl in env', prf, c1, c2, car, rel | None -> - let env' = - try clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl - with Pretype_errors.PretypeError _ -> - (* For Ring essentially, only when doing setoid_rewrite *) - clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl - in - let env' = - let mvs = clenv_dependent false env' in - clenv_pose_metas_as_evars env' mvs + let env' = clenv_unify ~flags:!hypinfo.flags CONV left t cl in + let env' = Clenvtac.clenv_pose_dependent_evars true env' in +(* let env' = Clenv.clenv_pose_metas_as_evars env' (Evd.undefined_metas env'.evd) in *) let evd' = Typeclasses.resolve_typeclasses ~fail:true env'.env env'.evd in let env' = { env' with evd = evd' } in let nf c = Evarutil.nf_evar evd' (Clenv.clenv_nf_meta env' c) in @@ -365,34 +380,83 @@ let unify_eqn env sigma hypinfo t = and ty2 = Typing.type_of env'.env env'.evd c2 in if convertible env env'.evd ty1 ty2 then ( - if occur_meta prf then - hypinfo := refresh_hypinfo env sigma !hypinfo; + if occur_meta_or_existential prf then + hypinfo := refresh_hypinfo env env'.evd !hypinfo; env', prf, c1, c2, car, rel) else raise Reduction.NotConvertible in let res = if l2r then (prf, (car, rel, c1, c2)) else - try (mkApp (get_symmetric_proof env Evd.empty car rel, + try (mkApp (get_symmetric_proof env env'.evd car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1)) with Not_found -> (prf, (car, inverse car rel, c2, c1)) - in Some (env', res) + in Some (env'.evd, res) with e when Class_tactics.catchable e -> None +(* let unify_eqn env sigma hypinfo t = *) +(* if isEvar t then None *) +(* else try *) +(* 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', prf, c1, c2, car, rel = *) +(* match abs with *) +(* | Some (absprf, absprfty) -> *) +(* let env' = clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl in *) +(* env'.evd, prf, c1, c2, car, rel *) +(* | None -> *) +(* let cl' = Clenv.clenv_pose_metas_as_evars cl (Evd.undefined_metas cl.evd) in *) +(* let sigma = cl'.evd in *) +(* let c1 = Clenv.clenv_nf_meta cl' c1 *) +(* and c2 = Clenv.clenv_nf_meta cl' c2 *) +(* and prf = Clenv.clenv_nf_meta cl' prf *) +(* and car = Clenv.clenv_nf_meta cl' car *) +(* and rel = Clenv.clenv_nf_meta cl' rel *) +(* in *) +(* let sigma' = *) +(* try Evarconv.the_conv_x ~ts:empty_transparent_state env t c1 sigma *) +(* with Reduction.NotConvertible _ -> *) +(* Evarconv.the_conv_x ~ts:conv_transparent_state env t c1 sigma *) +(* in *) +(* let sigma' = Evarconv.consider_remaining_unif_problems ~ts:conv_transparent_state env sigma' in *) +(* let evd' = Typeclasses.resolve_typeclasses ~fail:true env sigma' in *) +(* let nf c = Evarutil.nf_evar evd' c in *) +(* let c1 = nf c1 and c2 = nf c2 *) +(* and car = nf car and rel = nf rel *) +(* and prf' = nf prf in *) +(* if occur_meta_or_existential prf then *) +(* hypinfo := refresh_hypinfo env evd' !hypinfo; *) +(* evd', prf', c1, c2, car, rel *) +(* in *) +(* let res = *) +(* if l2r then (prf, (car, rel, c1, c2)) *) +(* else *) +(* try (mkApp (get_symmetric_proof env Evd.empty car rel, *) +(* [| c1 ; c2 ; prf |]), *) +(* (car, rel, c2, c1)) *) +(* with Not_found -> *) +(* (prf, (car, inverse car rel, c2, c1)) *) +(* in Some (evd', res) *) +(* with Reduction.NotConvertible -> None *) +(* | 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_id t = +let unfold_all t = match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_id) *) -> b + | 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_all t = +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 @@ -400,9 +464,6 @@ let unfold_all t = | _ -> assert false) | _ -> assert false -let decomp_prod env evm n c = - snd (Reductionops.splay_prod_n env evm n c) - let rec decomp_pointwise n c = if n = 0 then c else @@ -430,31 +491,35 @@ let pointwise_or_dep_relation n t car rel = mkApp (Lazy.force forall_relation, [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]) -let lift_cstr env sigma evars (args : constr list) ty cstr = +let lift_cstr env sigma evars (args : constr list) c ty cstr = let start env car = match cstr with | None | Some (_, None) -> Evarutil.e_new_evar evars env (mk_relation car) | Some (ty, Some rel) -> rel in - let rec aux env prod n args = - if n = 0 then Some (start env prod) + let rec aux env prod n = + if n = 0 then start 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 rb = aux env b' (pred n) (List.tl args) in - Option.map (fun rb -> mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |])) - rb + let rb = aux env b' (pred n) in + mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |]) else - let rb = aux (Environ.push_rel (na, None, ty) env) b (pred n) (List.tl args) in - Option.map - (fun rb -> mkApp (Lazy.force forall_relation, - [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |])) - rb - | _ -> None - in Option.map (fun rel -> (ty, rel)) (aux env ty (List.length args) args) + let rb = aux (Environ.push_rel (na, None, ty) env) b (pred n) in + 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 Some (aux env ty (succ (List.length args)), 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 @@ -470,7 +535,7 @@ type rewrite_proof = | RewPrf of constr * constr | RewCast of cast_kind -let get_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None +let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None type rewrite_result_info = { rew_car : constr; @@ -482,16 +547,21 @@ type rewrite_result_info = { type rewrite_result = rewrite_result_info option -type strategy = Environ.env -> evar_map -> constr -> types -> +type strategy = Environ.env -> identifier list -> constr -> types -> constr option -> evars -> rewrite_result option +let get_rew_rel r = match r.rew_prf with + | RewPrf (rel, prf) -> rel + | RewCast c -> mkApp (Coqlib.build_coq_eq (), [| r.rew_car; r.rew_from; r.rew_to |]) + let get_rew_prf r = match r.rew_prf with - | RewPrf (rel, prf) -> prf + | RewPrf (rel, prf) -> rel, prf | RewCast c -> - mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]), - c, mkApp (Coqlib.build_coq_eq (), [| r.rew_car; r.rew_from; r.rew_to |])) + 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 |]), + c, mkApp (rel, [| r.rew_from; r.rew_to |])) -let resolve_subrelation env sigma car rel prf rel' res = +let resolve_subrelation env avoid car rel prf rel' res = if eq_constr rel rel' then res else (* try let evd' = Evarconv.the_conv_x env rel rel' res.rew_evars in *) @@ -504,15 +574,15 @@ let resolve_subrelation env sigma car rel prf rel' res = rew_prf = RewPrf (rel', appsub); rew_evars = evars } -let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars = +let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars = let evars, morph_instance, proj, sigargs, m', args, args' = let first = try (array_find args' (fun i b -> b <> None)) with Not_found -> raise (Invalid_argument "resolve_morphism") in let morphargs, morphobjs = array_chop first args in let morphargs', morphobjs' = array_chop first args' in let appm = mkApp(m, morphargs) in - let appmtype = Typing.type_of env sigma appm in - let cstrs = List.map (Option.map (fun r -> r.rew_car, get_rew_rel r.rew_prf)) (Array.to_list morphobjs') 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') in (* Desired signature *) let evars, appmtype', signature, sigargs = build_signature evars env appmtype cstrs cstr @@ -540,7 +610,7 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars let evars, proof = proper_proof env evars carrier relation x in [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' | Some r -> - [ get_rew_prf r; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') + [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') | None -> if y <> None then error "Cannot rewrite the argument of a dependent function"; x :: acc, x :: subst, evars, sigargs, x :: typeargs') @@ -552,10 +622,10 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars [ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt | _ -> assert(false) -let apply_constraint env sigma car rel prf cstr res = +let apply_constraint env avoid car rel prf cstr res = match cstr with | None -> res - | Some r -> resolve_subrelation env sigma car rel prf r res + | Some r -> resolve_subrelation env avoid car rel prf r res let eq_env x y = x == y @@ -564,29 +634,27 @@ let apply_rule hypinfo loccs : strategy = let is_occ occ = if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in let occ = ref 0 in - fun env sigma t ty cstr evars -> - if not (eq_env !hypinfo.cl.env env) then hypinfo := refresh_hypinfo env sigma !hypinfo; - let unif = unify_eqn env sigma hypinfo t 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 (goalevars evars) hypinfo t in if unif <> None then incr occ; match unif with - | Some (env', (prf, (car, rel, c1, c2))) when is_occ !occ -> + | Some (evd', (prf, (car, rel, c1, c2))) when is_occ !occ -> begin if eq_constr t c2 then Some None else - let goalevars = Evd.evar_merge (fst evars) - (Evd.undefined_evars (Evarutil.nf_evar_map env'.evd)) - in let res = { rew_car = ty; rew_from = c1; - rew_to = c2; rew_prf = RewPrf (rel, prf); rew_evars = goalevars, snd evars } - in Some (Some (apply_constraint env sigma car rel prf cstr res)) + rew_to = c2; rew_prf = RewPrf (rel, prf); + rew_evars = evd', cstrevars evars } + in Some (Some (apply_constraint env avoid car rel prf cstr res)) end | _ -> None -let apply_lemma (evm,c) left2right loccs : strategy = - fun env sigma -> - let evars = Evd.merge sigma evm in - let hypinfo = ref (decompose_applied_relation env evars c left2right) in - apply_rule hypinfo loccs env sigma +let apply_lemma flags (evm,c) left2right loccs : strategy = + fun env avoid t ty cstr evars -> + let hypinfo = ref (decompose_applied_relation env (goalevars evars) flags None c left2right) in + apply_rule hypinfo loccs env avoid t ty cstr evars let make_leibniz_proof c ty r = let prf = @@ -658,9 +726,15 @@ let unfold_match env sigma sk app = let v = Environ.constant_value (Global.env ()) sk in Reductionops.whd_beta sigma (mkApp (v, args)) | _ -> app - + +let is_rew_cast = function RewCast _ -> true | _ -> false + +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 : strategy) : strategy = - let rec aux env sigma t ty cstr evars = + let rec aux env avoid t ty cstr evars = let cstr' = Option.map (fun c -> (ty, Some c)) cstr in match kind_of_term t with | App (m, args) -> @@ -670,7 +744,7 @@ let subterm all flags (s : strategy) : strategy = (fun (acc, evars, progress) arg -> if progress <> None && not all then (None :: acc, evars, progress) else - let res = s env sigma arg (Typing.type_of env sigma arg) None evars in + let res = s env avoid arg (Typing.type_of env (goalevars evars) arg) None evars in match res with | Some None -> (None :: acc, evars, if progress = None then Some false else progress) | Some (Some r) -> (Some r :: acc, r.rew_evars, Some true) @@ -682,19 +756,38 @@ let subterm all flags (s : strategy) : strategy = | Some false -> Some None | Some true -> let args' = Array.of_list (List.rev args') in - let evars', prf, car, rel, c1, c2 = resolve_morphism env sigma t m args args' cstr' evars' in - let res = { rew_car = ty; rew_from = c1; - rew_to = c2; rew_prf = RewPrf (rel, prf); - rew_evars = evars' } - in - Some (Some res) + if array_exists + (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 res = { rew_car = ty; rew_from = c1; + rew_to = c2; rew_prf = RewPrf (rel, prf); + 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' + in + let res = { rew_car = ty; rew_from = t; + rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; + rew_evars = evars' } + in Some (Some res) + in if flags.on_morphisms then let evarsref = ref (snd evars) in - let mty = Typing.type_of env sigma m in - let argsl = Array.to_list args in - let cstr' = lift_cstr env sigma evarsref argsl mty None in - let m' = s env sigma m mty (Option.map snd cstr') (fst evars, !evarsref) in + let mty = Typing.type_of env (goalevars evars) m in + let cstr', m, mty, argsl, args = + let argsl = Array.to_list args in + match lift_cstr env (goalevars evars) evarsref argsl m mty None with + | Some (cstr', m, mty, args) -> Some cstr', m, mty, args, Array.of_list args + | None -> None, m, mty, argsl, args + in + let m' = s env avoid m mty cstr' (fst evars, !evarsref) in match m' with | None -> rewrite_args None (* Standard path, try rewrite on arguments *) | Some None -> rewrite_args (Some false) @@ -714,14 +807,14 @@ let subterm all flags (s : strategy) : strategy = in match prf with | RewPrf (rel, prf) -> - Some (Some (apply_constraint env sigma res.rew_car rel prf cstr res)) + Some (Some (apply_constraint env avoid res.rew_car rel prf 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 sigma x and tb = Typing.type_of env sigma b in - let res = aux env sigma (mkApp (arrow_morphism tx tb, [| x; b |])) ty cstr evars in + let tx = Typing.type_of env (goalevars evars) x and tb = Typing.type_of env (goalevars evars) b in + let res = aux env avoid (mkApp (arrow_morphism tx tb, [| x; b |])) ty cstr evars in (match res with | Some (Some r) -> Some (Some { r with rew_to = unfold_impl r.rew_to }) | _ -> res) @@ -740,22 +833,28 @@ let subterm all flags (s : strategy) : strategy = (* in res, occ *) (* else *) - | Prod (n, dom, codom) when eq_constr ty mkProp -> + | Prod (n, dom, codom) -> let lam = mkLambda (n, dom, codom) in - let res = aux env sigma (mkApp (Lazy.force coq_all, [| dom; lam |])) ty cstr evars in + let 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 + in + let res = aux env avoid app ty cstr evars in (match res with - | Some (Some r) -> Some (Some { r with rew_to = unfold_all r.rew_to }) - | _ -> res) + | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to }) + | _ -> res) | Lambda (n, t, b) when flags.under_lambdas -> - let env' = Environ.push_rel (n, None, t) env in - let b' = s env' sigma b (Typing.type_of env' sigma b) (unlift_cstr env sigma cstr) evars in + 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 b' = s env' avoid b (Typing.type_of env' (goalevars evars) 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 + 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 @@ -767,38 +866,47 @@ let subterm all flags (s : strategy) : strategy = | _ -> b') | Case (ci, p, c, brs) -> - let cty = Typing.type_of env sigma c in + let cty = Typing.type_of env (goalevars evars) c in let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in - let c' = s env sigma c cty cstr' evars in - (match c' with + let c' = s env avoid c cty cstr' evars in + let res = + match c' with | Some (Some r) -> - Some (Some (make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r)) + let res = make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r in + Some (Some (coerce env avoid cstr res)) | x -> - if array_for_all ((=) 0) ci.ci_cstr_nargs then - let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in - let found, brs' = Array.fold_left (fun (found, acc) br -> - if found <> None then (found, fun x -> lift 1 br :: acc x) - else - match s env sigma br ty 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 sigma t) with Not_found -> None with + if array_for_all ((=) 0) ci.ci_cstr_ndecls then + let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in + let found, brs' = Array.fold_left + (fun (found, acc) br -> + if found <> None then (found, fun x -> lift 1 br :: acc x) + else + match s env avoid br ty 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 - | Some (cst, _, t') -> - match aux env sigma t' ty cstr evars with - | Some (Some prf) -> Some (Some { prf with - rew_from = t; rew_to = unfold_match env sigma cst prf.rew_to }) - | x' -> x) - - | _ -> if all then Some None else None + else + match try Some (fold_match env (goalevars evars) t) with Not_found -> None with + | None -> x + | Some (cst, _, t') -> + match aux env avoid t' ty 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 cstr r)) + | x -> x) + | _ -> None in aux let all_subterms = subterm true default_flags @@ -807,8 +915,8 @@ let one_subterm = subterm false default_flags (** Requires transitivity of the rewrite step, if not a reduction. Not tail-recursive. *) -let transitivity env sigma (res : rewrite_result_info) (next : strategy) : rewrite_result option = - match next env sigma res.rew_to res.rew_car (get_rew_rel res.rew_prf) res.rew_evars with +let transitivity env avoid (res : rewrite_result_info) (next : strategy) : rewrite_result option = + match next env avoid res.rew_to res.rew_car (get_opt_rew_rel res.rew_prf) res.rew_evars with | None -> None | Some None -> Some (Some res) | Some (Some res') -> @@ -835,13 +943,13 @@ module Strategies = struct let fail : strategy = - fun env sigma t ty cstr evars -> None + fun env avoid t ty cstr evars -> None let id : strategy = - fun env sigma t ty cstr evars -> Some None + fun env avoid t ty cstr evars -> Some None let refl : strategy = - fun env sigma t ty cstr evars -> + fun env avoid t ty cstr evars -> let evars, rel = match cstr with | None -> new_cstr_evar evars env (mk_relation ty) | Some r -> evars, r @@ -854,23 +962,23 @@ module Strategies = rew_prf = RewPrf (rel, proof); rew_evars = evars }) let progress (s : strategy) : strategy = - fun env sigma t ty cstr evars -> - match s env sigma t ty cstr evars with + 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 fst snd : strategy = - fun env sigma t ty cstr evars -> - match fst env sigma t ty cstr evars with + fun env avoid t ty cstr evars -> + match fst env avoid t ty cstr evars with | None -> None - | Some None -> snd env sigma t ty cstr evars - | Some (Some res) -> transitivity env sigma res snd + | Some None -> snd env avoid t ty cstr evars + | Some (Some res) -> transitivity env avoid res snd let choice fst snd : strategy = - fun env sigma t ty cstr evars -> - match fst env sigma t ty cstr evars with - | None -> snd env sigma t ty cstr evars + 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 @@ -896,33 +1004,51 @@ module Strategies = let outermost (s : strategy) : strategy = fix (fun out -> choice s (one_subterm out)) - let lemmas cs : strategy = + let lemmas flags cs : strategy = List.fold_left (fun tac (l,l2r) -> - choice tac (apply_lemma l l2r (false,[]))) + choice tac (apply_lemma flags l l2r (false,[]))) fail cs let inj_open c = (Evd.empty,c) let old_hints (db : string) : strategy = let rules = Autorewrite.find_rewrites db in - lemmas (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules) + lemmas rewrite_unif_flags + (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules) let hints (db : string) : strategy = - fun env sigma t ty cstr evars -> + fun env avoid t ty cstr evars -> let rules = Autorewrite.find_matches db t in - lemmas (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules) - env sigma t ty cstr evars + let lemma hint = (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r) in + let lems = List.map lemma rules in + lemmas rewrite_unif_flags lems env avoid t ty cstr evars let reduce (r : Redexpr.red_expr) : strategy = let rfn, ckind = Redexpr.reduction_of_red_expr r in - fun env sigma t ty cstr evars -> - let t' = rfn env sigma t in + fun env avoid t ty cstr evars -> + let t' = rfn env (goalevars evars) t in if eq_constr t' t then Some None else 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 _ -> 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, cstrevars evars }) + with _ -> None + end @@ -934,49 +1060,34 @@ let rewrite_strat flags occs hyp = Strategies.choice app (subterm true flags (fun env -> aux () env)) in aux () -let rewrite_with {it = c; sigma = evm} left2right loccs : strategy = - fun env sigma -> - let evars = Evd.merge sigma evm in - let hypinfo = ref (decompose_applied_relation env evars c left2right) in - rewrite_strat default_flags loccs hypinfo env sigma +let get_hypinfo_ids {c = opt} = + match opt with + | None -> [] + | Some (is, gc) -> List.map fst is.lfun @ is.avoid_ids -let apply_strategy (s : strategy) env sigma concl cstr evars = +let rewrite_with flags c left2right loccs : strategy = + fun env avoid t ty cstr evars -> + let gevars = goalevars evars in + 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 cstr evars = let res = - s env sigma concl (Typing.type_of env sigma concl) - (Option.map snd cstr) !evars + s env avoid + concl (Typing.type_of env (goalevars evars) concl) + (Option.map snd cstr) evars in match res with | None -> None | Some None -> Some None | Some (Some res) -> - evars := res.rew_evars; - Some (Some (res.rew_prf, (res.rew_car, res.rew_from, res.rew_to))) - -let split_evars_once sigma evd = - Evd.fold (fun ev evi deps -> - if Intset.mem ev deps then - Intset.union (Class_tactics.evars_of_evi evi) deps - else deps) evd sigma - -let existentials_of_evd evd = - Evd.fold (fun ev evi acc -> Intset.add ev acc) evd Intset.empty - -let evd_of_existentials evd exs = - Intset.fold (fun i acc -> - let evi = Evd.find evd i in - Evd.add acc i evi) exs Evd.empty - -let split_evars sigma evd = - let rec aux deps = - let deps' = split_evars_once deps evd in - if Intset.equal deps' deps then - evd_of_existentials evd deps - else aux deps' - in aux (existentials_of_evd sigma) + Some (Some (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to)) let merge_evars (goal,cstr) = Evd.merge goal cstr let solve_constraints env evars = - Typeclasses.resolve_typeclasses env ~split:false ~fail:true (merge_evars evars) + Typeclasses.resolve_typeclasses env ~split:false ~fail:true + (merge_evars evars) let nf_zeta = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) @@ -987,12 +1098,9 @@ let map_rewprf f = function exception RewriteFailure -let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = - let concl, is_hyp = - match clause with - Some id -> pf_get_hyp_typ gl id, Some id - | None -> pf_concl gl, None - in +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 @@ -1000,82 +1108,205 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = | None -> (sort, inverse sort impl) | Some _ -> (sort, impl) in - let sigma = project gl in - let evars = ref (Evd.create_evar_defs sigma, Evd.empty) in - let env = pf_env gl in - let eq = apply_strategy strat env sigma concl (Some cstr) evars in + let evars = (sigma, Evd.empty) in + let eq = apply_strategy strat env avoid concl (Some cstr) evars in match eq with - | Some (Some (p, (car, oldt, newt))) -> - (try - let cstrevars = !evars in - let evars = solve_constraints env cstrevars 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 undef = split_evars (fst cstrevars) evars in - let rewtac = - 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 - cut_replacing id newt - (Tacmach.refine_no_check (mkApp (term, [| mkVar id |]))) - | RewCast c -> - change_in_hyp None newt (id, InHypTypeOnly)) - - | None -> - (match p with - | RewPrf (rel, p) -> - (match abs with - | None -> - let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in - tclTHENLAST - (Tacmach.internal_cut_no_check false name newt) - (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p)) - | Some (t, ty) -> - Tacmach.refine_no_check - (mkApp (mkLambda (Name (id_of_string "newt"), newt, - mkLambda (Name (id_of_string "lemma"), ty, - mkApp (p, [| mkRel 2 |]))), - [| mkMeta goal_meta; t |]))) - | RewCast c -> - change_in_concl None newt) - in - let evartac = - if not (undef = Evd.empty) then - Refiner.tclEVARS undef - else tclIDTAC - in tclTHENLIST [evartac; rewtac] gl - with - | Stdpp.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e))) - | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> - Refiner.tclFAIL_lazy 0 - (lazy (str"setoid rewrite failed: unable to satisfy the rewriting constraints." - ++ fnl () ++ Himsg.explain_typeclass_error env e)) gl) + | Some (Some (p, evars, car, oldt, newt)) -> + let evars' = solve_constraints env evars 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. *) +(* let cstrs = cstrevars evars in *) + (* cstrs is small *) + let gevars = goalevars evars in + Evd.fold (fun ev evi acc -> + if Evd.mem gevars ev then Evd.add acc ev evi + else acc) evars' Evd.empty +(* Evd.fold (fun ev evi acc -> Evd.remove acc ev) cstrs evars' *) + 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 in + let treat res = + match res with + | None -> raise RewriteFailure | Some None -> - tclFAIL 0 (str"setoid rewrite failed: no progress made") gl + tclFAIL 0 (str"setoid rewrite failed: no progress made") + | 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 -> + 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) + (tclTHEN (Tactics.revert [name]) (Tacmach.refine p)) + | None, None -> change_in_concl None newt + in tclTHEN (evartac undef) tac + in + let tac = + try + let concl, is_hyp = + match clause with + | Some id -> pf_get_hyp_typ gl id, Some id + | None -> pf_concl gl, None + in + let sigma = project gl 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 + | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e))) + | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> + Refiner.tclFAIL_lazy 0 + (lazy (str"setoid rewrite failed: unable to satisfy the rewriting constraints." + ++ fnl () ++ Himsg.explain_typeclass_error env e)) + in tac gl + +open Goal +open Environ + +let bind_gl_info f = + bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) + +let fail l s = + raise (Refiner.FailError (l, lazy s)) + +let new_refine c : Goal.subgoals Goal.sensitive = + let refable = Goal.Refinable.make + (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 + (fun concl env sigma -> + let nc' = + Environ.fold_named_context + (fun _ (n, b, t as decl) nc' -> + if n = id then (n, b, newt) :: nc' + else decl :: nc') + env ~init:[] + in + 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 -> + Goal.bind (Refinable.mkEvar h env newt) + (fun ev' -> + let inst = + fold_named_context + (fun _ (n, b, t) inst -> + if n = id then ev' :: inst + else if b = None then mkVar n :: inst else inst) + env ~init:[] + in + let (e, args) = destEvar ev in + Goal.return (mkEvar (e, Array.of_list inst))))) + in Goal.bind reft Goal.refine) + in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) + (Proofview.tclFOCUS 2 2 tac) + +let cl_rewrite_clause_newtac ?abs strat clause = + let treat (res, is_hyp) = + match res with | None -> raise RewriteFailure - -let cl_rewrite_clause_strat strat clause gl = + | Some None -> + fail 0 (str"setoid rewrite failed: no progress made") + | 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) -> + Proofview.tclSENSITIVE (Goal.convert_hyp false (id, None, newt)) + | None, (undef, Some p, newt) -> + let refable = Goal.Refinable.make + (fun handle -> + Goal.bind env + (fun env -> Goal.bind (Refinable.mkEvar handle env newt) + (fun ev -> + Goal.Refinable.constr_of_open_constr handle true + (undef, mkApp (p, [| ev |]))))) + in + Proofview.tclSENSITIVE (Goal.bind refable Goal.refine) + | None, (undef, None, newt) -> + Proofview.tclSENSITIVE (Goal.convert_concl false newt) + in + let info = + bind_gl_info + (fun concl env sigma -> + let ty, is_hyp = + match clause with + | Some id -> Environ.named_type id env, Some id + | None -> concl, None + in + let res = + try cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp + with + | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e))) + | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> + fail 0 (str"setoid rewrite failed: unable to satisfy the rewriting constraints." + ++ fnl () ++ Himsg.explain_typeclass_error env e) + in return (res, is_hyp)) + in Proofview.tclGOALBINDU info (fun i -> treat i) + +let cl_rewrite_clause_new_strat ?abs strat clause = init_setoid (); - let meta = Evarutil.new_meta() in - let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in - try cl_rewrite_clause_aux strat meta clause gl + try cl_rewrite_clause_newtac ?abs strat clause with RewriteFailure -> - tclFAIL 0 (str"setoid rewrite failed: strategy failed") gl + fail 0 (str"setoid rewrite failed: strategy failed") + +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 gl = + init_setoid (); + let meta = Evarutil.new_meta() in +(* let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in *) + try cl_rewrite_clause_tac strat (mkMeta meta) clause gl + with RewriteFailure -> + tclFAIL 0 (str"setoid rewrite failed: strategy failed") gl let cl_rewrite_clause l left2right occs clause gl = - cl_rewrite_clause_strat (rewrite_with l left2right occs) clause gl + cl_rewrite_clause_strat (rewrite_with (general_rewrite_unif_flags ()) l left2right occs) clause gl open Pp open Pcoq @@ -1093,18 +1324,10 @@ let occurrences_of = function error "Illegal negative occurrence number."; (true,nl) -let pr_gen_strategy pr_id = Pp.mt () -let pr_loc_strategy _ _ _ = Pp.mt () -let pr_strategy _ _ _ (s : strategy) = Pp.str "" - -let intern_strategy ist gl c = c -let interp_strategy ist gl c = c -let glob_strategy ist l = l -let subst_strategy evm l = l - -let apply_constr_expr c l2r occs = fun env sigma -> - let evd, c = Constrintern.interp_open_constr sigma env c in - apply_lemma (evd, (c, NoBindings)) l2r occs env sigma +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, (c, NoBindings)) + l2r occs env avoid t ty cstr (evd, cstrevars evars) let interp_constr_list env sigma = List.map (fun c -> @@ -1113,13 +1336,49 @@ let interp_constr_list env sigma = open Pcoq -let (wit_strategy, globwit_strategy, rawwit_strategy) = +type constr_expr_with_bindings = constr_expr with_bindings +type glob_constr_with_bindings = glob_constr_and_expr with_bindings +type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings + +let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge))) +let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge)) +let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) +let interp_glob_constr_with_bindings ist gl c = (ist, c) +let glob_glob_constr_with_bindings ist l = Tacinterp.intern_constr_with_bindings ist l +let subst_glob_constr_with_bindings s c = subst_glob_with_bindings s c + + +ARGUMENT EXTEND glob_constr_with_bindings + PRINTED BY pr_glob_constr_with_bindings_sign + + INTERPRETED BY interp_glob_constr_with_bindings + GLOBALIZED BY glob_glob_constr_with_bindings + SUBSTITUTED BY subst_glob_constr_with_bindings + + RAW_TYPED AS constr_expr_with_bindings + RAW_PRINTED BY pr_constr_expr_with_bindings + + GLOB_TYPED AS glob_constr_with_bindings + GLOB_PRINTED BY pr_glob_constr_with_bindings + + [ constr_with_bindings(bl) ] -> [ bl ] +END + +let _ = (Genarg.create_arg "strategy" : ((strategy, Genarg.tlevel) Genarg.abstract_argument_type * (strategy, Genarg.glevel) Genarg.abstract_argument_type * (strategy, Genarg.rlevel) Genarg.abstract_argument_type)) + +let pr_strategy _ _ _ (s : strategy) = Pp.str "" + +let interp_strategy ist gl c = c +let glob_strategy ist l = l +let subst_strategy evm l = l + + ARGUMENT EXTEND rewstrategy TYPED AS strategy PRINTED BY pr_strategy INTERPRETED BY interp_strategy @@ -1146,57 +1405,62 @@ ARGUMENT EXTEND rewstrategy TYPED AS strategy | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ Strategies.choice h h' ] | [ "old_hints" preident(h) ] -> [ Strategies.old_hints h ] | [ "hints" preident(h) ] -> [ Strategies.hints h ] - | [ "terms" constr_list(h) ] -> [ fun env sigma -> - Strategies.lemmas (interp_constr_list env sigma h) env sigma ] - | [ "eval" red_expr(r) ] -> [ fun env sigma -> - Strategies.reduce (Tacinterp.interp_redexp env sigma r) env sigma ] + | [ "terms" constr_list(h) ] -> [ fun env avoid t ty cstr evars -> + Strategies.lemmas rewrite_unif_flags (interp_constr_list env (goalevars evars) h) env avoid t ty cstr evars ] + | [ "eval" red_expr(r) ] -> [ fun env avoid t ty cstr evars -> + Strategies.reduce (Tacinterp.interp_redexp env (goalevars evars) r) env avoid t ty cstr evars ] + | [ "fold" constr(c) ] -> [ Strategies.fold c ] END -TACTIC EXTEND class_rewrite -| [ "clrewrite" orient(o) constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] -| [ "clrewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] -| [ "clrewrite" orient(o) constr_with_bindings(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id) ] -| [ "clrewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ] -| [ "clrewrite" orient(o) constr_with_bindings(c) ] -> [ cl_rewrite_clause c o all_occurrences None ] - END - -TACTIC EXTEND class_rewrite_strat -| [ "clrewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] -(* | [ "clrewrite_strat" strategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] *) +TACTIC EXTEND rewrite_strat +| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] +| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] END - let clsubstitute o c = - let is_tac id = match kind_of_term (fst c.it) with Var id' when id' = id -> true | _ -> false in + let is_tac id = match fst (fst (snd c)) with GVar (_, id') when id' = id -> true | _ -> false in Tacticals.onAllHypsAndConcl (fun cl -> match cl with | Some id when is_tac id -> tclIDTAC - | _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl)) + | _ -> cl_rewrite_clause c o all_occurrences cl) TACTIC EXTEND substitute -| [ "substitute" orient(o) constr_with_bindings(c) ] -> [ clsubstitute o c ] +| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ] END (* Compatibility with old Setoids *) TACTIC EXTEND setoid_rewrite - [ "setoid_rewrite" orient(o) constr_with_bindings(c) ] + [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] -> [ cl_rewrite_clause c o all_occurrences None ] - | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "in" hyp(id) ] -> + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id)] - | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) ] -> + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None] - | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id)] - | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id)] END -(* let solve_obligation lemma = *) -(* tclTHEN (Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor None))) *) -(* (eapply_with_bindings (Constrintern.interp_constr Evd.empty (Global.env()) lemma, NoBindings)) *) +let cl_rewrite_clause_newtac_tac c o occ cl gl = + cl_rewrite_clause_newtac' c o occ cl; + tclIDTAC gl + +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 all_occurrences (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 all_occurrences None ] +END let mkappc s l = CAppExpl (dummy_loc,(None,(Libnames.Ident (dummy_loc,id_of_string s))),l) @@ -1207,78 +1471,75 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] -let anew_instance binders instance fields = - new_instance binders instance (CRecord (dummy_loc,None,fields)) ~generalize:false None +let anew_instance global binders instance fields = + new_instance binders instance (Some (CRecord (dummy_loc,None,fields))) + ~global:(not (Vernacexpr.use_section_locality ())) ~generalize:false None -let require_library dirpath = - let qualid = (dummy_loc, Libnames.qualid_of_dirpath (Libnames.dirpath_of_string dirpath)) in - Library.require_library [qualid] (Some false) - -let declare_instance_refl binders a aeq n lemma = +let declare_instance_refl global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance binders instance + in anew_instance global binders instance [(Ident (dummy_loc,id_of_string "reflexivity"),lemma)] -let declare_instance_sym binders a aeq n lemma = +let declare_instance_sym global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" - in anew_instance binders instance + in anew_instance global binders instance [(Ident (dummy_loc,id_of_string "symmetry"),lemma)] -let declare_instance_trans binders a aeq n lemma = +let declare_instance_trans global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" - in anew_instance binders instance + in anew_instance global binders instance [(Ident (dummy_loc,id_of_string "transitivity"),lemma)] -let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None))) - let declare_relation ?(binders=[]) a aeq n refl symm trans = init_setoid (); + let global = not (Vernacexpr.use_section_locality ()) in let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" - in ignore(anew_instance binders instance []); + in ignore(anew_instance global binders instance []); match (refl,symm,trans) with (None, None, None) -> () | (Some lemma1, None, None) -> - ignore (declare_instance_refl binders a aeq n lemma1) + ignore (declare_instance_refl global binders a aeq n lemma1) | (None, Some lemma2, None) -> - ignore (declare_instance_sym binders a aeq n lemma2) + ignore (declare_instance_sym global binders a aeq n lemma2) | (None, None, Some lemma3) -> - ignore (declare_instance_trans binders a aeq n lemma3) + ignore (declare_instance_trans global binders a aeq n lemma3) | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl binders a aeq n lemma1); - ignore (declare_instance_sym binders a aeq n lemma2) + ignore (declare_instance_refl global binders a aeq n lemma1); + ignore (declare_instance_sym global binders a aeq n lemma2) | (Some lemma1, None, Some lemma3) -> - let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in - let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in + let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( - anew_instance binders instance + anew_instance global binders instance [(Ident (dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1); (Ident (dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)]) | (None, Some lemma2, Some lemma3) -> - let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in + let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( - anew_instance binders instance + anew_instance global binders instance [(Ident (dummy_loc,id_of_string "PER_Symmetric"), lemma2); (Ident (dummy_loc,id_of_string "PER_Transitive"),lemma3)]) | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in - let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in + let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in + let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( - anew_instance binders instance + anew_instance global binders instance [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1); (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2); (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)]) type 'a binders_argtype = (local_binder list, 'a) Genarg.abstract_argument_type -let (wit_binders : Genarg.tlevel binders_argtype), - (globwit_binders : Genarg.glevel binders_argtype), - (rawwit_binders : Genarg.rlevel binders_argtype) = - Genarg.create_arg "binders" +let _, _, rawwit_binders = + (Genarg.create_arg "binders" : + Genarg.tlevel binders_argtype * + Genarg.glevel binders_argtype * + Genarg.rlevel binders_argtype) open Pcoq.Constr @@ -1349,9 +1610,6 @@ VERNAC COMMAND EXTEND AddParametricRelation3 [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] END -let mk_qualid s = - Libnames.Qualid (dummy_loc, Libnames.qualid_of_string s) - let cHole = CHole (dummy_loc, None) open Entries @@ -1392,9 +1650,9 @@ let declare_projection n instance_id r = let typ = it_mkProd_or_LetIn typ ctx in let cst = { const_entry_body = term; + const_entry_secctx = None; const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_boxed = false } + const_entry_opaque = false } in ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) @@ -1441,14 +1699,14 @@ let default_morphism sign m = let evars, mor = resolve_one_typeclass env (merge_evars evars) morph in mor, proper_projection mor morph -let add_setoid binders a aeq t n = +let add_setoid global binders a aeq t n = init_setoid (); - let _lemma_refl = declare_instance_refl binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym = declare_instance_sym binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans = declare_instance_trans binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( - anew_instance binders instance + anew_instance global binders instance [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) @@ -1458,8 +1716,8 @@ let add_morphism_infer glob m n = let instance_id = add_suffix n "_Proper" in let instance = build_morphism_signature m in if Lib.is_modtype () then - let cst = Declare.declare_internal_constant instance_id - (Entries.ParameterEntry (instance,false), Decl_kinds.IsAssumption Decl_kinds.Logical) + let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id + (Entries.ParameterEntry (None,instance,None), Decl_kinds.IsAssumption Decl_kinds.Logical) in add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst)); declare_projection n instance_id (ConstRef cst) @@ -1487,14 +1745,14 @@ let add_morphism glob binders m s n = [cHole; s; m])) in let tac = Tacinterp.interp <:tactic> in - ignore(new_instance ~global:glob binders instance (CRecord (dummy_loc,None,[])) + ignore(new_instance ~global:glob binders instance (Some (CRecord (dummy_loc,None,[]))) ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) VERNAC COMMAND EXTEND AddSetoid1 [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ add_setoid [] a aeq t n ] + [ add_setoid (not (Vernacexpr.use_section_locality ())) [] a aeq t n ] | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ add_setoid binders a aeq t n ] + [ add_setoid (not (Vernacexpr.use_section_locality ())) binders a aeq t n ] | [ "Add" "Morphism" constr(m) ":" ident(n) ] -> [ add_morphism_infer (not (Vernacexpr.use_section_locality ())) m n ] | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] -> @@ -1529,40 +1787,43 @@ 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 gl = +let unification_rewrite flags l2r c1 c2 cl car rel but gl = let env = pf_env gl 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 ~flags:rewrite_unif_flags env ((if l2r then c1 else c2),but) cl.evd + Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env cl.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 - env ((if l2r then c1 else c2),but) cl.evd + Unification.w_unify_to_subterm ~flags:flags + env cl.evd ((if l2r then c1 else c2),but) in let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in let cl' = {cl with evd = evd'} in - let cl' = - let mvs = clenv_dependent false cl' in - clenv_pose_metas_as_evars cl' mvs - in - let nf c = Evarutil.nf_evar ( cl'.evd) (Clenv.clenv_nf_meta cl' c) in + let cl' = Clenvtac.clenv_pose_dependent_evars true cl' in + let nf c = Evarutil.nf_evar cl'.evd (Clenv.clenv_nf_meta cl' c) in let c1 = if l2r then nf c' else nf c1 and c2 = if l2r then nf c2 else nf c' 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 - {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)} + {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty); + flags = flags} let get_hyp gl evars (c,l) clause l2r = - let hi = decompose_applied_relation (pf_env gl) evars (c,l) l2r in - let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in - unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl + let flags = rewrite2_unif_flags in + let hi = decompose_applied_relation (pf_env gl) evars flags None (c,l) l2r in + let but = match clause with + | Some id -> pf_get_hyp_typ gl id + | None -> Evarutil.nf_evar evars (pf_concl gl) + in + { unification_rewrite flags hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl with + flags = rewrite_unif_flags } let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } @@ -1578,13 +1839,14 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = let meta = Evarutil.new_meta() in let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in try - tclTHEN - (Refiner.tclEVARS hypinfo.cl.evd) - (cl_rewrite_clause_aux ~abs:hypinfo.abs strat meta cl) gl + tclWEAK_PROGRESS + (tclTHEN + (Refiner.tclEVARS hypinfo.cl.evd) + (cl_rewrite_clause_tac ~abs:hypinfo.abs strat (mkMeta meta) cl)) gl with RewriteFailure -> let {l2r=l2r; c1=x; c2=y} = hypinfo in raise (Pretype_errors.PretypeError - (pf_env gl, + (pf_env gl,project gl, Pretype_errors.NoOccurrenceFound ((if l2r then x else y), cl))) let general_s_rewrite_clause x = @@ -1595,15 +1857,6 @@ let general_s_rewrite_clause x = let _ = Equality.register_general_rewrite_clause general_s_rewrite_clause -let is_loaded d = - let d' = List.map id_of_string d in - let dir = make_dirpath (List.rev d') in - Library.library_is_loaded dir - -let try_loaded f gl = - if is_loaded ["Coq";"Classes";"RelationClasses"] then f gl - else tclFAIL 0 (str"You need to require Coq.Classes.RelationClasses first") gl - (** [setoid_]{reflexivity,symmetry,transitivity} tactics *) let not_declared env ty rel = @@ -1641,7 +1894,7 @@ let setoid_transitivity c gl = let proof = get_transitive_proof env evm car rel in match c with | None -> eapply proof - | Some c -> apply_with_bindings (proof,Rawterm.ImplicitBindings [ c ])) + | Some c -> apply_with_bindings (proof,Glob_term.ImplicitBindings [ c ])) (transitivity_red true c) let setoid_symmetry_in id gl = @@ -1721,3 +1974,35 @@ TACTIC EXTEND fold_matches let c' = fold_matches (pf_env gl) (project gl) c in change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ] END + +TACTIC EXTEND myapply +| [ "myapply" global(id) constr_list(l) ] -> [ + fun gl -> + let gr = id in + let _, impls = List.hd (Impargs.implicits_of_global gr) in + let ty = Global.type_of_global gr in + let env = pf_env gl in + let evars = ref (project gl) 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 (constr_of_global gr, Array.of_list (List.rev args')) + in aux ty impls l [] + in + tclTHEN (Refiner.tclEVARS !evars) (apply app) gl ] +END diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 6a11384b..a41cd6e7 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* @@ -60,20 +60,18 @@ let error_syntactic_metavariables_not_allowed loc = (loc,"out_ident", str "Syntactic metavariables allowed only in quotations.") +let error_tactic_expected loc = + user_err_loc (loc,"",str "Tactic expected.") + let error_global_not_found_loc (loc,qid) = error_global_not_found_loc loc qid let skip_metaid = function | AI x -> x | MetaId (loc,_) -> error_syntactic_metavariables_not_allowed loc -type ltac_type = - | LtacFun of ltac_type - | LtacBasic - | LtacTactic - (* Values for interpretation *) type value = - | VRTactic of (goal list sigma * validation) (* For Match results *) + | VRTactic of (goal list sigma) (* For Match results *) (* Not a true value *) | VFun of ltac_trace * (identifier*value) list * identifier option list * glob_tactic_expr @@ -93,15 +91,15 @@ let dloc = dummy_loc let catch_error call_trace tac g = if call_trace = [] then tac g else try tac g with | LtacLocated _ as e -> raise e - | Stdpp.Exc_located (_,LtacLocated _) as e -> raise e + | Loc.Exc_located (_,LtacLocated _) as e -> raise e | e -> let (nrep,loc',c),tail = list_sep_last call_trace in - let loc,e' = match e with Stdpp.Exc_located(loc,e) -> loc,e | _ ->dloc,e in + let loc,e' = match e with Loc.Exc_located(loc,e) -> loc,e | _ ->dloc,e in if tail = [] then let loc = if loc = dloc then loc' else loc in - raise (Stdpp.Exc_located(loc,e')) + raise (Loc.Exc_located(loc,e')) else - raise (Stdpp.Exc_located(loc',LtacLocated((nrep,c,tail,loc),e'))) + raise (Loc.Exc_located(loc',LtacLocated((nrep,c,tail,loc),e'))) (* Signature for interpretation: val_interp and interpretation functions *) type interp_sign = @@ -137,9 +135,9 @@ let rec pr_value env = function | VList (a::_) -> str "a list (first element is " ++ pr_value env a ++ str")" -(* Transforms an id into a constr if possible, or fails *) +(* Transforms an id into a constr if possible, or fails with Not_found *) let constr_of_id env id = - construct_reference (Environ.named_context env) id + Term.mkVar (let _ = Environ.lookup_named id env in id) (* To embed tactics *) let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t), @@ -159,25 +157,6 @@ let valueOut = function | ast -> anomalylabstrm "valueOut" (str "Not a Dynamic ast: ") -(* To embed constr *) -let constrIn t = CDynamic (dummy_loc,constr_in t) -let constrOut = function - | CDynamic (_,d) -> - if (Dyn.tag d) = "constr" then - constr_out d - else - anomalylabstrm "constrOut" (str "Dynamic tag should be constr") - | ast -> - anomalylabstrm "constrOut" (str "Not a Dynamic ast") - -(* Globalizes the identifier *) -let find_reference env qid = - (* We first look for a variable of the current proof *) - match repr_qualid qid with - | (d,id) when repr_dirpath d = [] & List.mem id (ids_of_context env) - -> VarRef id - | _ -> Nametab.locate qid - (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) let atomic_mactab = ref Idmap.empty let add_primitive_tactic s tac = @@ -213,7 +192,7 @@ let _ = (fun (s,t) -> add_primitive_tactic s t) [ "idtac",TacId []; "fail", TacFail(ArgArg 0,[]); - "fresh", TacArg(TacFreshId []) + "fresh", TacArg(dloc,TacFreshId []) ] let lookup_atomic id = Idmap.find id !atomic_mactab @@ -347,15 +326,6 @@ let intern_name l ist = function | Anonymous -> Anonymous | Name id -> Name (intern_ident l ist id) -let vars_of_ist (lfun,_,_,env) = - List.fold_left (fun s id -> Idset.add id s) - (vars_of_env env) lfun - -let get_current_context () = - try Pfedit.get_current_goal_context () - with e when Logic.catchable_exception e -> - (Evd.empty, Global.env()) - let strict_check = ref false let adjust_loc loc = if !strict_check then dloc else loc @@ -402,12 +372,12 @@ let intern_ltac_variable ist = function let intern_constr_reference strict ist = function | Ident (_,id) as r when not strict & find_hyp id ist -> - RVar (dloc,id), Some (CRef r) + GVar (dloc,id), Some (CRef r) | Ident (_,id) as r when find_ctxvar id ist -> - RVar (dloc,id), if strict then None else Some (CRef r) + GVar (dloc,id), if strict then None else Some (CRef r) | r -> let loc,_ as lqid = qualid_of_reference r in - RRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r) + GRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r) let intern_move_location ist = function | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id) @@ -525,12 +495,6 @@ let intern_bindings ist = function let intern_constr_with_bindings ist (c,bl) = (intern_constr ist c, intern_bindings ist bl) -let intern_clause_pattern ist (l,occl) = - let rec check = function - | (hyp,l) :: rest -> (intern_hyp ist (skip_metaid hyp),l)::(check rest) - | [] -> [] - in (l,check occl) - (* TODO: catch ltac vars *) let intern_induction_arg ist = function | ElimOnConstr c -> ElimOnConstr (intern_constr_with_bindings ist c) @@ -539,7 +503,7 @@ let intern_induction_arg ist = function if !strict_check then (* If in a defined tactic, no intros-until *) match intern_constr ist (CRef (Ident (dloc,id))) with - | RVar (loc,id),_ -> ElimOnIdent (loc,id) + | GVar (loc,id),_ -> ElimOnIdent (loc,id) | c -> ElimOnConstr (c,NoBindings) else ElimOnIdent (loc,id) @@ -592,7 +556,7 @@ let intern_typed_pattern ist p = let dummy_pat = PRel 0 in (* we cannot ensure in non strict mode that the pattern is closed *) (* keeping a constr_expr copy is too complicated and we want anyway to *) - (* type it, so we remember the pattern as a rawconstr only *) + (* type it, so we remember the pattern as a glob_constr only *) (intern_constr_gen true false ist p,dummy_pat) let intern_typed_pattern_with_occurrences ist (l,p) = @@ -735,7 +699,7 @@ let rec intern_atomic lf ist x = TacMutualCofix (b,intern_ident lf ist id, List.map f l) | TacCut c -> TacCut (intern_type ist c) | TacAssert (otac,ipat,c) -> - TacAssert (Option.map (intern_tactic ist) otac, + TacAssert (Option.map (intern_pure_tactic ist) otac, Option.map (intern_intro_pattern lf ist) ipat, intern_constr_gen false (otac<>None) ist c) | TacGeneralize cl -> @@ -797,8 +761,8 @@ let rec intern_atomic lf ist x = | TacLeft (ev,bl) -> TacLeft (ev,intern_bindings ist bl) | TacRight (ev,bl) -> TacRight (ev,intern_bindings ist bl) | TacSplit (ev,b,bll) -> TacSplit (ev,b,List.map (intern_bindings ist) bll) - | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (intern_tactic ist) t) - | TacConstructor (ev,n,bl) -> TacConstructor (ev,n,intern_bindings ist bl) + | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (intern_pure_tactic ist) t) + | TacConstructor (ev,n,bl) -> TacConstructor (ev,intern_or_var ist n,intern_bindings ist bl) (* Conversion *) | TacReduce (r,cl) -> @@ -826,7 +790,7 @@ let rec intern_atomic lf ist x = (ev, List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings ist c)) l, clause_app (intern_hyp_location ist) cl, - Option.map (intern_tactic ist) by) + Option.map (intern_pure_tactic ist) by) | TacInversion (inv,hyp) -> TacInversion (intern_inversion_strength lf ist inv, intern_quantified_hypothesis ist hyp) @@ -839,9 +803,9 @@ let rec intern_atomic lf ist x = let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in TacAlias (loc,s,l,(dir,body)) -and intern_tactic ist tac = (snd (intern_tactic_seq ist tac) : glob_tactic_expr) +and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) -and intern_tactic_seq ist = function +and intern_tactic_seq onlytac ist = function | TacAtom (loc,t) -> let lf = ref ist.ltacvars in let t = intern_atomic lf ist t in @@ -851,50 +815,68 @@ and intern_tactic_seq ist = function let (l1,l2) = ist.ltacvars in let ist' = { ist with ltacvars = (extract_let_names l @ l1, l2) } in let l = List.map (fun (n,b) -> - (n,intern_tacarg !strict_check (if isrec then ist' else ist) b)) l in - ist.ltacvars, TacLetIn (isrec,l,intern_tactic ist' u) + (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in + ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u) + | TacMatchGoal (lz,lr,lmr) -> - ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule ist lmr) + ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist lmr) | TacMatch (lz,c,lmr) -> - ist.ltacvars, TacMatch (lz,intern_tactic ist c,intern_match_rule ist lmr) + ist.ltacvars, + TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr) | TacId l -> ist.ltacvars, TacId (intern_message ist l) | TacFail (n,l) -> ist.ltacvars, TacFail (intern_or_var ist n,intern_message ist l) - | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac) - | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s) + | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac) + | TacAbstract (tac,s) -> + ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s) | TacThen (t1,[||],t2,[||]) -> - let lfun', t1 = intern_tactic_seq ist t1 in - let lfun'', t2 = intern_tactic_seq { ist with ltacvars = lfun' } t2 in + let lfun', t1 = intern_tactic_seq onlytac ist t1 in + let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in lfun'', TacThen (t1,[||],t2,[||]) | TacThen (t1,tf,t2,tl) -> - let lfun', t1 = intern_tactic_seq ist t1 in + let lfun', t1 = intern_tactic_seq onlytac ist t1 in let ist' = { ist with ltacvars = lfun' } in (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) - lfun', TacThen (t1,Array.map (intern_tactic ist') tf,intern_tactic ist' t2, - Array.map (intern_tactic ist') tl) + lfun', TacThen (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2, + Array.map (intern_pure_tactic ist') tl) | TacThens (t,tl) -> - let lfun', t = intern_tactic_seq ist t in + let lfun', t = intern_tactic_seq true ist t in let ist' = { ist with ltacvars = lfun' } in (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) - lfun', TacThens (t, List.map (intern_tactic ist') tl) + lfun', TacThens (t, List.map (intern_pure_tactic ist') tl) | TacDo (n,tac) -> - ist.ltacvars, TacDo (intern_or_var ist n,intern_tactic ist tac) - | TacTry tac -> ist.ltacvars, TacTry (intern_tactic ist tac) - | TacInfo tac -> ist.ltacvars, TacInfo (intern_tactic ist tac) - | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_tactic ist tac) + ist.ltacvars, TacDo (intern_or_var ist n,intern_pure_tactic ist tac) + | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac) + | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac) + | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac) + | TacTimeout (n,tac) -> + ist.ltacvars, TacTimeout (intern_or_var ist n,intern_tactic onlytac ist tac) | TacOrelse (tac1,tac2) -> - ist.ltacvars, TacOrelse (intern_tactic ist tac1,intern_tactic ist tac2) - | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_tactic ist) l) - | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_tactic ist) l) - | TacComplete tac -> ist.ltacvars, TacComplete (intern_tactic ist tac) - | TacArg a -> ist.ltacvars, TacArg (intern_tacarg true ist a) + ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) + | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) + | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) + | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) + | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a + +and intern_tactic_as_arg loc onlytac ist a = + match intern_tacarg !strict_check onlytac ist a with + | TacCall _ | TacExternal _ | Reference _ | TacDynamic _ as a -> TacArg (loc,a) + | Tacexp a -> a + | TacVoid | IntroPattern _ | Integer _ + | ConstrMayEval _ | TacFreshId _ as a -> + if onlytac then error_tactic_expected loc else TacArg (loc,a) + | MetaIdArg _ -> assert false + +and intern_tactic_or_tacarg ist = intern_tactic false ist + +and intern_pure_tactic ist = intern_tactic true ist and intern_tactic_fun ist (var,body) = let (l1,l2) = ist.ltacvars in let lfun' = List.rev_append (Option.List.flatten var) l1 in - (var,intern_tactic { ist with ltacvars = (lfun',l2) } body) + (var,intern_tactic_or_tacarg { ist with ltacvars = (lfun',l2) } body) -and intern_tacarg strict ist = function +and intern_tacarg strict onlytac ist = function | TacVoid -> TacVoid | Reference r -> intern_non_tactic_reference strict ist r | IntroPattern ipat -> @@ -907,34 +889,35 @@ and intern_tacarg strict ist = function let id = id_of_string s in if find_ltacvar id ist then if istac then Reference (ArgVar (adjust_loc loc,id)) - else ConstrMayEval (ConstrTerm (RVar (adjust_loc loc,id), None)) + else ConstrMayEval (ConstrTerm (GVar (adjust_loc loc,id), None)) else error_syntactic_metavariables_not_allowed loc | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f | TacCall (loc,f,l) -> TacCall (loc, intern_applied_tactic_reference ist f, - List.map (intern_tacarg !strict_check ist) l) + List.map (intern_tacarg !strict_check false ist) l) | TacExternal (loc,com,req,la) -> - TacExternal (loc,com,req,List.map (intern_tacarg !strict_check ist) la) + TacExternal (loc,com,req,List.map (intern_tacarg !strict_check false ist) la) | TacFreshId x -> TacFreshId (List.map (intern_or_var ist) x) - | Tacexp t -> Tacexp (intern_tactic ist t) + | Tacexp t -> Tacexp (intern_tactic onlytac ist t) | TacDynamic(loc,t) as x -> (match Dyn.tag t with - | "tactic" | "value" | "constr" -> x + | "tactic" | "value" -> x + | "constr" -> if onlytac then error_tactic_expected loc else x | s -> anomaly_loc (loc, "", str "Unknown dynamic: <" ++ str s ++ str ">")) (* Reads the rules of a Match Context or a Match *) -and intern_match_rule ist = function +and intern_match_rule onlytac ist = function | (All tc)::tl -> - All (intern_tactic ist tc) :: (intern_match_rule ist tl) + All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl) | (Pat (rl,mp,tc))::tl -> let {ltacvars=(lfun,l2); gsigma=sigma; genv=env} = ist in let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in let ido,metas2,pat = intern_pattern ist lfun mp in let metas = list_uniquize (metas1@metas2) in let ist' = { ist with ltacvars = (metas@(Option.List.cons ido lfun'),l2) } in - Pat (hyps,pat,intern_tactic ist' tc) :: (intern_match_rule ist tl) + Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl) | [] -> [] and intern_genarg ist x = @@ -990,30 +973,16 @@ and intern_genarg ist x = match tactic_genarg_level s with | Some n -> (* Special treatment of tactic arguments *) - in_gen (globwit_tactic n) (intern_tactic ist + in_gen (globwit_tactic n) (intern_tactic_or_tacarg ist (out_gen (rawwit_tactic n) x)) | None -> lookup_genarg_glob s ist x -let intern_pure_tactic ist a = - match intern_tactic ist a with - | TacArg (TacCall _ | TacExternal _ | Reference _ | TacDynamic _ | Tacexp _) as a -> a - | TacArg _ | TacFun _ -> error "Tactic expected." - | a -> a - (************* End globalization ************) (***************************************************************************) (* Evaluation/interpretation *) -let constr_to_id loc = function - | VConstr ([],c) when isVar c -> destVar c - | _ -> invalid_arg_loc (loc, "Not an identifier") - -let constr_to_qid loc c = - try shortest_qualid_of_global Idset.empty (global_of_constr c) - with _ -> invalid_arg_loc (loc, "Not a global reference") - let is_variable env id = List.mem id (ids_of_named_context (Environ.named_context env)) @@ -1053,7 +1022,7 @@ let try_interp_ltac_var coerce ist env (loc,id) = let interp_ltac_var coerce ist env locid = try try_interp_ltac_var coerce ist env locid - with Not_found -> anomaly "Detected as ltac var at interning time" + with Not_found -> anomaly ("Detected '" ^ (string_of_id (snd locid)) ^ "' as ltac var at interning time") (* Interprets an identifier which must be fresh *) let coerce_to_ident fresh env = function @@ -1161,16 +1130,6 @@ let interp_hyp_list_as_list ist gl (loc,id as x) = let interp_hyp_list ist gl l = List.flatten (List.map (interp_hyp_list_as_list ist gl) l) -let interp_clause_pattern ist gl (l,occl) = - let rec check acc = function - | (hyp,l) :: rest -> - let hyp = interp_hyp ist gl hyp in - if List.mem hyp acc then - error ("Hypothesis "^(string_of_id hyp)^" occurs twice."); - (hyp,l)::(check (hyp::acc) rest) - | [] -> [] - in (l,check [] occl) - let interp_move_location ist gl = function | MoveAfter id -> MoveAfter (interp_hyp ist gl id) | MoveBefore id -> MoveBefore (interp_hyp ist gl id) @@ -1284,58 +1243,6 @@ let interp_fresh_id ist env l = let pf_interp_fresh_id ist gl = interp_fresh_id ist (pf_env gl) -let implicit_tactic = ref None - -let declare_implicit_tactic tac = implicit_tactic := Some tac - -open Evd - -let solvable_by_tactic env evi (ev,args) src = - match (!implicit_tactic, src) with - | Some tac, (ImplicitArg _ | QuestionMark _) - when - Environ.named_context_of_val evi.evar_hyps = - Environ.named_context env -> - let id = id_of_string "H" in - start_proof id (Local,Proof Lemma) evi.evar_hyps evi.evar_concl - (fun _ _ -> ()); - begin - try - by (tclCOMPLETE tac); - let _,(const,_,_,_) = cook_proof ignore in - delete_current_proof (); const.const_entry_body - with e when Logic.catchable_exception e -> - delete_current_proof(); - raise Exit - end - | _ -> raise Exit - -let solve_remaining_evars fail_evar use_classes env initial_sigma evd c = - let evdref = - if use_classes then ref (Typeclasses.resolve_typeclasses ~fail:true env evd) - else ref evd in - let rec proc_rec c = - let c = Reductionops.whd_evar !evdref c in - match kind_of_term c with - | Evar (ev,args as k) when not (Evd.mem initial_sigma ev) -> - let (loc,src) = evar_source ev !evdref in - let sigma = !evdref in - let evi = Evd.find sigma ev in - (try - let c = solvable_by_tactic env evi k src in - evdref := Evd.define ev c !evdref; - c - with Exit -> - if fail_evar then - Pretype_errors.error_unsolvable_implicit loc env sigma evi src None - else - c) - | _ -> map_constr proc_rec c - in - let c = proc_rec c in - (* Side-effect *) - !evdref,c - let interp_gen kind ist allow_patvar expand_evar fail_evar use_classes env sigma (c,ce) = let (ltacvars,unbndltacvars as vars) = extract_ltac_constr_values ist env in let c = match ce with @@ -1348,13 +1255,14 @@ let interp_gen kind ist allow_patvar expand_evar fail_evar use_classes env sigma intern_gen (kind = IsType) ~allow_patvar ~ltacvars:ltacdata sigma env c in let trace = push_trace (dloc,LtacConstrInterp (c,vars)) ist.trace in - let evd,c = + let evdc = catch_error trace (understand_ltac expand_evar sigma env vars kind) c in - let evd,c = + let (evd,c) = if expand_evar then - solve_remaining_evars fail_evar use_classes env sigma evd c + solve_remaining_evars fail_evar use_classes + solve_by_implicit_tactic env sigma evdc else - evd,c in + evdc in db_constr ist.debug env c; (evd,c) @@ -1373,6 +1281,9 @@ let interp_open_constr_gen kind ist = let interp_open_constr ccl = interp_open_constr_gen (OfType ccl) +let interp_pure_open_constr ist = + interp_gen (OfType None) ist false false false false + let interp_typed_pattern ist env sigma (c,_) = let sigma, c = interp_gen (OfType None) ist true false false false env sigma c in @@ -1393,7 +1304,7 @@ let constr_list_of_VList env = function let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = let try_expand_ltac_var sigma x = try match dest_fun x with - | RVar (_,id), _ -> + | GVar (_,id), _ -> sigma, List.map inj_fun (constr_list_of_VList env (List.assoc id ist.lfun)) | _ -> @@ -1408,12 +1319,14 @@ let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = let interp_constr_list ist env sigma c = snd (interp_constr_in_compound_list (fun x -> x) (fun x -> x) (fun ist env sigma c -> (Evd.empty, interp_constr ist env sigma c)) ist env sigma c) -let inj_open c = (Evd.empty,c) - let interp_open_constr_list = interp_constr_in_compound_list (fun x -> x) (fun x -> x) (interp_open_constr None) +let interp_auto_lemmas ist env sigma lems = + let local_sigma, lems = interp_open_constr_list ist env sigma lems in + List.map (fun lem -> (local_sigma,lem)) lems + (* Interprets a type expression *) let pf_interp_type ist gl = interp_type ist (pf_env gl) (project gl) @@ -1476,7 +1389,7 @@ let interp_may_eval f ist gl = function f ist gl c with e -> debugging_exception_step ist false e (fun () -> - str"interpretation of term " ++ pr_rawconstr_env (pf_env gl) (fst c)); + str"interpretation of term " ++ pr_glob_constr_env (pf_env gl) (fst c)); raise e (* Interprets a constr expression possibly to first evaluate *) @@ -1612,41 +1525,48 @@ let interp_open_constr_with_bindings ist env sigma (c,bl) = let loc_of_bindings = function | NoBindings -> dummy_loc -| ImplicitBindings l -> loc_of_rawconstr (fst (list_last l)) +| ImplicitBindings l -> loc_of_glob_constr (fst (list_last l)) | ExplicitBindings l -> pi1 (list_last l) let interp_open_constr_with_bindings_loc ist env sigma ((c,_),bl as cb) = - let loc1 = loc_of_rawconstr c in + let loc1 = loc_of_glob_constr c in let loc2 = loc_of_bindings bl in let loc = if loc2 = dummy_loc then loc1 else join_loc loc1 loc2 in let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in sigma, (loc,cb) -let interp_induction_arg ist gl sigma arg = - let env = pf_env gl in +let interp_induction_arg ist gl arg = + let env = pf_env gl and sigma = project gl in match arg with | ElimOnConstr c -> - let sigma', (c,b) = interp_constr_with_bindings ist env sigma c in - let sigma, c = solve_remaining_evars false true env sigma sigma' c in - sigma, ElimOnConstr (c,b) - | ElimOnAnonHyp n as x -> sigma, x + ElimOnConstr (interp_constr_with_bindings ist env sigma c) + | ElimOnAnonHyp n as x -> x | ElimOnIdent (loc,id) -> try - sigma, match List.assoc id ist.lfun with - | VInteger n -> ElimOnAnonHyp n - | VIntroPattern (IntroIdentifier id) -> ElimOnIdent (loc,id) - | VConstr ([],c) -> ElimOnConstr (c,NoBindings) + | VInteger n -> + ElimOnAnonHyp n + | VIntroPattern (IntroIdentifier id') -> + if Tactics.is_quantified_hypothesis id' gl + then ElimOnIdent (loc,id') + else + (try ElimOnConstr (sigma,(constr_of_id env id',NoBindings)) + with Not_found -> + user_err_loc (loc,"", + pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis.")) + | VConstr ([],c) -> + ElimOnConstr (sigma,(c,NoBindings)) | _ -> user_err_loc (loc,"", strbrk "Cannot coerce " ++ pr_id id ++ strbrk " neither to a quantified hypothesis nor to a term.") with Not_found -> - (* Interactive mode *) + (* We were in non strict (interactive) mode *) if Tactics.is_quantified_hypothesis id gl then - sigma, ElimOnIdent (loc,id) + ElimOnIdent (loc,id) else - let c = interp_constr ist env sigma (RVar (loc,id),Some (CRef (Ident (loc,id)))) in - sigma, ElimOnConstr (c,NoBindings) + let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in + let c = interp_constr ist env sigma c in + ElimOnConstr (sigma,(c,NoBindings)) (* Associates variables with values and gives the remaining variables and values *) @@ -1811,11 +1731,11 @@ let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c) let pack_sigma (sigma,c) = {it=c;sigma=sigma} -let extend_gl_hyps gl sign = - { gl with - it = { gl.it with - evar_hyps = - List.fold_right Environ.push_named_context_val sign gl.it.evar_hyps } } +let extend_gl_hyps { it=gl ; sigma=sigma } sign = + let hyps = Goal.V82.hyps sigma gl in + let new_hyps = List.fold_right Environ.push_named_context_val sign hyps in + (* spiwack: (2010/01/13) if a bug was reintroduced in [change] in is probably here *) + Goal.V82.new_goal_with sigma gl new_hyps (* Interprets an l-tac expression into a value *) let rec val_interp ist gl (tac:glob_tactic_expr) = @@ -1827,7 +1747,7 @@ let rec val_interp ist gl (tac:glob_tactic_expr) = | TacLetIn (false,l,u) -> interp_letin ist gl l u | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr - | TacArg a -> interp_tacarg ist gl a + | TacArg (loc,a) -> interp_tacarg ist gl a (* Delayed evaluation *) | t -> VFun (ist.trace,ist.lfun,[],t) @@ -1860,6 +1780,7 @@ and eval_tactic ist = function (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) | TacThens (t1,tl) -> tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl) | TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac) + | TacTimeout (n,tac) -> tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac) | TacTry tac -> tclTRY (interp_tactic ist tac) | TacInfo tac -> let t = (interp_tactic ist tac) in @@ -1867,7 +1788,7 @@ and eval_tactic ist = function begin match tac with TacAtom (_,_) -> t - | _ -> abstract_tactic_expr (TacArg (Tacexp tac)) t + | _ -> abstract_tactic_expr (TacArg (dloc,Tacexp tac)) t end | TacRepeat tac -> tclREPEAT (interp_tactic ist tac) | TacOrelse (tac1,tac2) -> @@ -1979,19 +1900,19 @@ and eval_with_fail ist is_lazy goal tac = VRTactic (catch_error trace tac goal) | a -> a) with - | FailError (0,s) | Stdpp.Exc_located(_, FailError (0,s)) - | Stdpp.Exc_located(_,LtacLocated (_,FailError (0,s))) -> + | FailError (0,s) | Loc.Exc_located(_, FailError (0,s)) + | Loc.Exc_located(_,LtacLocated (_,FailError (0,s))) -> raise (Eval_fail (Lazy.force s)) | FailError (lvl,s) -> raise (FailError (lvl - 1, s)) - | Stdpp.Exc_located(s,FailError (lvl,s')) -> - raise (Stdpp.Exc_located(s,FailError (lvl - 1, s'))) - | Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) -> - raise (Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl - 1, s')))) + | Loc.Exc_located(s,FailError (lvl,s')) -> + raise (Loc.Exc_located(s,FailError (lvl - 1, s'))) + | Loc.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) -> + raise (Loc.Exc_located(s,LtacLocated (s'',FailError (lvl - 1, s')))) (* Interprets the clauses of a recursive LetIn *) and interp_letrec ist gl llc u = let lref = ref ist.lfun in - let lve = list_map_left (fun ((_,id),b) -> (id,VRec (lref,TacArg b))) llc in + let lve = list_map_left (fun ((_,id),b) -> (id,VRec (lref,TacArg (dloc,b)))) llc in lref := lve@ist.lfun; let ist = { ist with lfun = lve@ist.lfun } in val_interp ist gl u @@ -2005,6 +1926,8 @@ and interp_letin ist gl llc u = (* Interprets the Match Context expressions *) and interp_match_goal ist goal lz lr lmr = + let (gl,sigma) = Goal.V82.nf_evar (project goal) (sig_it goal) in + let goal = { it = gl ; sigma = sigma } in let hyps = pf_hyps goal in let hyps = if lr then List.rev hyps else hyps in let concl = pf_concl goal in @@ -2116,7 +2039,7 @@ and interp_genarg ist gl x = in_gen wit_sort (destSort (pf_interp_constr ist gl - (RSort (dloc,out_gen globwit_sort x), None))) + (GSort (dloc,out_gen globwit_sort x), None))) | ConstrArgType -> in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x)) | ConstrMayEvalArgType -> @@ -2152,7 +2075,7 @@ and interp_genarg ist gl x = | Some n -> (* Special treatment of tactic arguments *) in_gen (wit_tactic n) - (TacArg(valueIn(VFun(ist.trace,ist.lfun,[], + (TacArg(dloc,valueIn(VFun(ist.trace,ist.lfun,[], out_gen (globwit_tactic n) x)))) | None -> lookup_interp_genarg s ist gl x @@ -2189,9 +2112,9 @@ and interp_match ist g lz constr lmr = match_next_pattern find_next' () in match_next_pattern (fun () -> match_subterm_gen app c csr) () in let rec apply_match ist csr = function - | (All t)::_ -> + | (All t)::tl -> (try eval_with_fail ist lz g t - with e when is_match_catchable e -> apply_match ist csr []) + with e when is_match_catchable e -> apply_match ist csr tl) | (Pat ([],Term c,mt))::tl -> (try let lmatch = @@ -2337,23 +2260,31 @@ and interp_atomic ist gl tac = | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c) | TacLetTac (na,c,clp,b) -> let clp = interp_clause ist gl clp in - h_let_tac b (interp_fresh_name ist env na) (pf_interp_constr ist gl c) clp + if clp = nowhere then + (* We try to fully-typechect the term *) + h_let_tac b (interp_fresh_name ist env na) + (pf_interp_constr ist gl c) clp + else + (* We try to keep the pattern structure as much as possible *) + h_let_pat_tac b (interp_fresh_name ist env na) + (interp_pure_open_constr ist env sigma c) clp (* Automation tactics *) | TacTrivial (lems,l) -> - Auto.h_trivial (interp_constr_list ist env sigma lems) + Auto.h_trivial + (interp_auto_lemmas ist env sigma lems) (Option.map (List.map (interp_hint_base ist)) l) | TacAuto (n,lems,l) -> Auto.h_auto (Option.map (interp_int_or_var ist) n) - (interp_constr_list ist env sigma lems) - (Option.map (List.map (interp_hint_base ist)) l) + (interp_auto_lemmas ist env sigma lems) + (Option.map (List.map (interp_hint_base ist)) l) | TacAutoTDB n -> Dhyp.h_auto_tdb n | TacDestructHyp (b,id) -> Dhyp.h_destructHyp b (interp_hyp ist gl id) | TacDestructConcl -> Dhyp.h_destructConcl | TacSuperAuto (n,l,b1,b2) -> Auto.h_superauto n l b1 b2 | TacDAuto (n,p,lems) -> Auto.h_dauto (Option.map (interp_int_or_var ist) n,p) - (interp_constr_list ist env sigma lems) + (interp_auto_lemmas ist env sigma lems) (* Derived basic tactics *) | TacSimpleInductionDestruct (isrec,h) -> @@ -2361,8 +2292,7 @@ and interp_atomic ist gl tac = | TacInductionDestruct (isrec,ev,(l,cls)) -> let sigma, l = list_fold_map (fun sigma (lc,cbo,(ipato,ipats)) -> - let sigma,lc = - list_fold_map (interp_induction_arg ist gl) sigma lc in + let lc = List.map (interp_induction_arg ist gl) lc in let sigma,cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in (sigma,(lc,cbo, @@ -2410,7 +2340,7 @@ and interp_atomic ist gl tac = (Tactics.any_constructor ev (Option.map (interp_tactic ist) t)) | TacConstructor (ev,n,bl) -> let sigma, bl = interp_bindings ist env sigma bl in - tclWITHHOLES ev (h_constructor ev (skip_metaid n)) sigma bl + tclWITHHOLES ev (h_constructor ev (interp_int_or_var ist n)) sigma bl (* Conversion *) | TacReduce (r,cl) -> @@ -2553,7 +2483,7 @@ let make_empty_glob_sign () = (* Initial call for interpretation *) let interp_tac_gen lfun avoid_ids debug t gl = interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] } - (intern_tactic { + (intern_tactic true { ltacvars = (List.map fst lfun, []); ltacrecvars = []; gsigma = project gl; genv = pf_env gl } t) gl @@ -2566,18 +2496,18 @@ let interp t = interp_tac_gen [] [] (get_debug()) t let eval_ltac_constr gl t = interp_ltac_constr { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } gl - (intern_tactic (make_empty_glob_sign ()) t ) + (intern_tactic_or_tacarg (make_empty_glob_sign ()) t ) (* Hides interpretation for pretty-print *) let hide_interp t ot gl = let ist = { ltacvars = ([],[]); ltacrecvars = []; gsigma = project gl; genv = pf_env gl } in - let te = intern_tactic ist t in + let te = intern_tactic true ist t in let t = eval_tactic te in match ot with - | None -> abstract_tactic_expr (TacArg (Tacexp te)) t gl + | None -> abstract_tactic_expr (TacArg (dloc,Tacexp te)) t gl | Some t' -> - abstract_tactic_expr ~dflt:true (TacArg (Tacexp te)) (tclTHEN t t') gl + abstract_tactic_expr ~dflt:true (TacArg (dloc,Tacexp te)) (tclTHEN t t') gl (***************************************************************************) (* Substitution at module closing time *) @@ -2586,25 +2516,25 @@ let subst_quantified_hypothesis _ x = x let subst_declared_or_quantified_hypothesis _ x = x -let subst_rawconstr_and_expr subst (c,e) = +let subst_glob_constr_and_expr subst (c,e) = assert (e=None); (* e<>None only for toplevel tactics *) - (Detyping.subst_rawconstr subst c,None) + (Detyping.subst_glob_constr subst c,None) -let subst_rawconstr = subst_rawconstr_and_expr (* shortening *) +let subst_glob_constr = subst_glob_constr_and_expr (* shortening *) let subst_binding subst (loc,b,c) = - (loc,subst_quantified_hypothesis subst b,subst_rawconstr subst c) + (loc,subst_quantified_hypothesis subst b,subst_glob_constr subst c) let subst_bindings subst = function | NoBindings -> NoBindings - | ImplicitBindings l -> ImplicitBindings (List.map (subst_rawconstr subst) l) + | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l) | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l) -let subst_raw_with_bindings subst (c,bl) = - (subst_rawconstr subst c, subst_bindings subst bl) +let subst_glob_with_bindings subst (c,bl) = + (subst_glob_constr subst c, subst_bindings subst bl) let subst_induction_arg subst = function - | ElimOnConstr c -> ElimOnConstr (subst_raw_with_bindings subst c) + | ElimOnConstr c -> ElimOnConstr (subst_glob_with_bindings subst c) | ElimOnAnonHyp n as x -> x | ElimOnIdent id as x -> x @@ -2645,17 +2575,17 @@ let subst_unfold subst (l,e) = let subst_flag subst red = { red with rConst = List.map (subst_evaluable subst) red.rConst } -let subst_constr_with_occurrences subst (l,c) = (l,subst_rawconstr subst c) +let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) -let subst_rawconstr_or_pattern subst (c,p) = - (subst_rawconstr subst c,subst_pattern subst p) +let subst_glob_constr_or_pattern subst (c,p) = + (subst_glob_constr subst c,subst_pattern subst p) let subst_pattern_with_occurrences subst (l,p) = - (l,subst_rawconstr_or_pattern subst p) + (l,subst_glob_constr_or_pattern subst p) let subst_redexp subst = function | Unfold l -> Unfold (List.map (subst_unfold subst) l) - | Fold l -> Fold (List.map (subst_rawconstr subst) l) + | Fold l -> Fold (List.map (subst_glob_constr subst) l) | Cbv f -> Cbv (subst_flag subst f) | Lazy f -> Lazy (subst_flag subst f) | Pattern l -> Pattern (List.map (subst_constr_with_occurrences subst) l) @@ -2663,14 +2593,14 @@ let subst_redexp subst = function | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r let subst_raw_may_eval subst = function - | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_rawconstr subst c) - | ConstrContext (locid,c) -> ConstrContext (locid,subst_rawconstr subst c) - | ConstrTypeOf c -> ConstrTypeOf (subst_rawconstr subst c) - | ConstrTerm c -> ConstrTerm (subst_rawconstr subst c) + | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c) + | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c) + | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c) + | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c) let subst_match_pattern subst = function - | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_rawconstr_or_pattern subst pc)) - | Term pc -> Term (subst_rawconstr_or_pattern subst pc) + | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc)) + | Term pc -> Term (subst_glob_constr_or_pattern subst pc) let rec subst_match_goal_hyps subst = function | Hyp (locs,mp) :: tl -> @@ -2685,54 +2615,54 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Basic tactics *) | TacIntroPattern _ | TacIntrosUntil _ | TacIntroMove _ as x -> x | TacAssumption as x -> x - | TacExact c -> TacExact (subst_rawconstr subst c) - | TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c) - | TacVmCastNoCheck c -> TacVmCastNoCheck (subst_rawconstr subst c) + | TacExact c -> TacExact (subst_glob_constr subst c) + | TacExactNoCheck c -> TacExactNoCheck (subst_glob_constr subst c) + | TacVmCastNoCheck c -> TacVmCastNoCheck (subst_glob_constr subst c) | TacApply (a,ev,cb,cl) -> - TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb,cl) + TacApply (a,ev,List.map (subst_glob_with_bindings subst) cb,cl) | TacElim (ev,cb,cbo) -> - TacElim (ev,subst_raw_with_bindings subst cb, - Option.map (subst_raw_with_bindings subst) cbo) - | TacElimType c -> TacElimType (subst_rawconstr subst c) - | TacCase (ev,cb) -> TacCase (ev,subst_raw_with_bindings subst cb) - | TacCaseType c -> TacCaseType (subst_rawconstr subst c) + TacElim (ev,subst_glob_with_bindings subst cb, + Option.map (subst_glob_with_bindings subst) cbo) + | TacElimType c -> TacElimType (subst_glob_constr subst c) + | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings subst cb) + | TacCaseType c -> TacCaseType (subst_glob_constr subst c) | TacFix (idopt,n) as x -> x | TacMutualFix (b,id,n,l) -> - TacMutualFix(b,id,n,List.map (fun (id,n,c) -> (id,n,subst_rawconstr subst c)) l) + TacMutualFix(b,id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) | TacCofix idopt as x -> x | TacMutualCofix (b,id,l) -> - TacMutualCofix (b,id, List.map (fun (id,c) -> (id,subst_rawconstr subst c)) l) - | TacCut c -> TacCut (subst_rawconstr subst c) + TacMutualCofix (b,id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) + | TacCut c -> TacCut (subst_glob_constr subst c) | TacAssert (b,na,c) -> - TacAssert (Option.map (subst_tactic subst) b,na,subst_rawconstr subst c) + TacAssert (Option.map (subst_tactic subst) b,na,subst_glob_constr subst c) | TacGeneralize cl -> TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) - | TacGeneralizeDep c -> TacGeneralizeDep (subst_rawconstr subst c) - | TacLetTac (id,c,clp,b) -> TacLetTac (id,subst_rawconstr subst c,clp,b) + | TacGeneralizeDep c -> TacGeneralizeDep (subst_glob_constr subst c) + | TacLetTac (id,c,clp,b) -> TacLetTac (id,subst_glob_constr subst c,clp,b) (* Automation tactics *) - | TacTrivial (lems,l) -> TacTrivial (List.map (subst_rawconstr subst) lems,l) - | TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_rawconstr subst) lems,l) + | TacTrivial (lems,l) -> TacTrivial (List.map (subst_glob_constr subst) lems,l) + | TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_glob_constr subst) lems,l) | TacAutoTDB n -> TacAutoTDB n | TacDestructHyp (b,id) -> TacDestructHyp(b,id) | TacDestructConcl -> TacDestructConcl | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2) - | TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_rawconstr subst) lems) + | TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_glob_constr subst) lems) (* Derived basic tactics *) | TacSimpleInductionDestruct (isrec,h) as x -> x | TacInductionDestruct (isrec,ev,(l,cls)) -> TacInductionDestruct (isrec,ev,(List.map (fun (lc,cbo,ids) -> List.map (subst_induction_arg subst) lc, - Option.map (subst_raw_with_bindings subst) cbo, ids) l, cls)) + Option.map (subst_glob_with_bindings subst) cbo, ids) l, cls)) | TacDoubleInduction (h1,h2) as x -> x - | TacDecomposeAnd c -> TacDecomposeAnd (subst_rawconstr subst c) - | TacDecomposeOr c -> TacDecomposeOr (subst_rawconstr subst c) + | 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 - TacDecompose (l,subst_rawconstr subst c) - | TacSpecialize (n,l) -> TacSpecialize (n,subst_raw_with_bindings subst l) - | TacLApply c -> TacLApply (subst_rawconstr subst c) + 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) (* Context management *) | TacClear _ as x -> x @@ -2751,24 +2681,24 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Conversion *) | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) | TacChange (op,c,cl) -> - TacChange (Option.map (subst_rawconstr_or_pattern subst) op, - subst_rawconstr subst c, cl) + TacChange (Option.map (subst_glob_constr_or_pattern subst) op, + subst_glob_constr subst c, cl) (* Equivalence relations *) | TacReflexivity | TacSymmetry _ as x -> x - | TacTransitivity c -> TacTransitivity (Option.map (subst_rawconstr subst) c) + | TacTransitivity c -> TacTransitivity (Option.map (subst_glob_constr subst) c) (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> TacRewrite (ev, List.map (fun (b,m,c) -> - b,m,subst_raw_with_bindings subst c) l, + b,m,subst_glob_with_bindings subst c) l, cl,Option.map (subst_tactic subst) by) | TacInversion (DepInversion (k,c,l),hyp) -> - TacInversion (DepInversion (k,Option.map (subst_rawconstr subst) c,l),hyp) + TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp) | TacInversion (NonDepInversion _,_) as x -> x | TacInversion (InversionUsing (c,cl),hyp) -> - TacInversion (InversionUsing (subst_rawconstr subst c,cl),hyp) + TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) (* For extensions *) | TacExtend (_loc,opn,l) -> @@ -2796,6 +2726,7 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with | TacThens (t,tl) -> TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl) | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac) + | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac) | TacTry tac -> TacTry (subst_tactic subst tac) | TacInfo tac -> TacInfo (subst_tactic subst tac) | TacRepeat tac -> TacRepeat (subst_tactic subst tac) @@ -2804,7 +2735,7 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) | TacComplete tac -> TacComplete (subst_tactic subst tac) - | TacArg a -> TacArg (subst_tacarg subst a) + | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) @@ -2855,7 +2786,7 @@ and subst_genarg subst (x:glob_generic_argument) = | SortArgType -> in_gen globwit_sort (out_gen globwit_sort x) | ConstrArgType -> - in_gen globwit_constr (subst_rawconstr subst (out_gen globwit_constr x)) + in_gen globwit_constr (subst_glob_constr subst (out_gen globwit_constr x)) | ConstrMayEvalArgType -> in_gen globwit_constr_may_eval (subst_raw_may_eval subst (out_gen globwit_constr_may_eval x)) | QuantHypArgType -> @@ -2866,10 +2797,10 @@ and subst_genarg subst (x:glob_generic_argument) = in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x)) | OpenConstrArgType b -> in_gen (globwit_open_constr_gen b) - ((),subst_rawconstr subst (snd (out_gen (globwit_open_constr_gen b) x))) + ((),subst_glob_constr subst (snd (out_gen (globwit_open_constr_gen b) x))) | ConstrWithBindingsArgType -> in_gen globwit_constr_with_bindings - (subst_raw_with_bindings subst (out_gen globwit_constr_with_bindings x)) + (subst_glob_with_bindings subst (out_gen globwit_constr_with_bindings x)) | BindingsArgType -> in_gen globwit_bindings (subst_bindings subst (out_gen globwit_bindings x)) @@ -2889,11 +2820,6 @@ and subst_genarg subst (x:glob_generic_argument) = (***************************************************************************) (* Tactic registration *) -(* For bad tactic calls *) -let bad_tactic_args s = - anomalylabstrm s - (str "Tactic " ++ str s ++ str " called with bad arguments") - (* Declaration of the TAC-DEFINITION object *) let add (kn,td) = mactab := Gmap.add kn td !mactab let replace (kn,td) = mactab := Gmap.add kn td (Gmap.remove kn !mactab) @@ -2938,7 +2864,7 @@ let subst_md (subst,(local,defs)) = let classify_md (local,defs as o) = if local then Dispose else Substitute o -let (inMD,outMD) = +let inMD : bool * (tacdef_kind * glob_tactic_expr) list -> obj = declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; @@ -2946,12 +2872,22 @@ let (inMD,outMD) = subst_function = subst_md; classify_function = classify_md} +let rec split_ltac_fun = function + | TacFun (l,t) -> (l,t) + | t -> ([],t) + +let pr_ltac_fun_arg = function + | None -> spc () ++ str "_" + | Some id -> spc () ++ pr_id id + let print_ltac id = try let kn = Nametab.locate_tactic id in - let t = lookup kn in - str "Ltac" ++ spc() ++ pr_qualid id ++ str " :=" ++ spc() ++ - Pptactic.pr_glob_tactic (Global.env ()) t + let l,t = split_ltac_fun (lookup kn) in + hv 2 ( + hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++ + prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") + ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) with Not_found -> errorlabstrm "print_ltac" @@ -2991,7 +2927,7 @@ let add_tacdef local isrec tacl = let gtacl = List.map2 (fun (_,b,def) (id, qid) -> let k = if b then UpdateTac qid else NewTac (Option.get id) in - let t = Flags.with_option strict_check (intern_tactic ist) def in + let t = Flags.with_option strict_check (intern_tactic_or_tacarg ist) def in (k, t)) tacl rfun in let id0 = fst (List.hd rfun) in @@ -3009,11 +2945,11 @@ let add_tacdef local isrec tacl = (* Other entry points *) let glob_tactic x = - Flags.with_option strict_check (intern_tactic (make_empty_glob_sign ())) x + Flags.with_option strict_check (intern_tactic true (make_empty_glob_sign ())) x let glob_tactic_env l env x = Flags.with_option strict_check - (intern_tactic + (intern_pure_tactic { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env }) x @@ -3025,14 +2961,16 @@ let interp_redexp env sigma r = (***************************************************************************) (* Embed tactics in raw or glob tactic expr *) -let globTacticIn t = TacArg (TacDynamic (dummy_loc,tactic_in t)) +let globTacticIn t = TacArg (dloc,TacDynamic (dloc,tactic_in t)) let tacticIn t = globTacticIn (fun ist -> try glob_tactic (t ist) - with e -> raise (AnomalyOnError ("Incorrect tactic expression", e))) + with e -> anomalylabstrm "tacticIn" + (str "Incorrect tactic expression. Received exception is:" ++ + Errors.print e)) let tacticOut = function - | TacArg (TacDynamic (_,d)) -> + | TacArg (_,TacDynamic (_,d)) -> if (Dyn.tag d) = "tactic" then tactic_out d else @@ -3051,6 +2989,6 @@ let _ = Auto.set_extern_interp let _ = Auto.set_extern_intern_tac (fun l -> Flags.with_option strict_check - (intern_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])})) + (intern_pure_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])})) let _ = Auto.set_extern_subst_tactic subst_tactic let _ = Dhyp.set_extern_interp eval_tactic diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 8f585781..d9dc8094 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Environ.env -> Pretyping.ltac_var_map -(* Transforms an id into a constr if possible *) -val constr_of_id : Environ.env -> identifier -> constr - -(* To embed several objects in Coqast.t *) +(** To embed several objects in Coqast.t *) val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t val tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr) val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr val valueIn : value -> raw_tactic_arg -val constrIn : constr -> constr_expr -(* Sets the debugger mode *) +(** Sets the debugger mode *) val set_debug : debug_info -> unit -(* Gives the state of debug *) +(** Gives the state of debug *) val get_debug : unit -> debug_info -(* Adds a definition for tactics in the table *) +(** Adds a definition for tactics in the table *) val add_tacdef : Vernacexpr.locality_flag -> bool -> (Libnames.reference * bool * raw_tactic_expr) list -> unit val add_primitive_tactic : string -> glob_tactic_expr -> unit -(* Tactic extensions *) +(** Tactic extensions *) val add_tactic : string -> (typed_generic_argument list -> tactic) -> unit val overwriting_add_tactic : @@ -78,7 +70,7 @@ val overwriting_add_tactic : val lookup_tactic : string -> (typed_generic_argument list) -> tactic -(* Adds an interpretation function for extra generic arguments *) +(** Adds an interpretation function for extra generic arguments *) type glob_sign = { ltacvars : identifier list * identifier list; ltacrecvars : (identifier * Nametab.ltac_constant) list; @@ -99,18 +91,15 @@ val interp_genarg : val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument -val intern_tactic : - glob_sign -> raw_tactic_expr -> glob_tactic_expr - val intern_pure_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr val intern_constr : - glob_sign -> constr_expr -> rawconstr_and_expr + glob_sign -> constr_expr -> glob_constr_and_expr val intern_constr_with_bindings : - glob_sign -> constr_expr * constr_expr Rawterm.bindings -> - rawconstr_and_expr * rawconstr_and_expr Rawterm.bindings + glob_sign -> constr_expr * constr_expr Glob_term.bindings -> + glob_constr_and_expr * glob_constr_and_expr Glob_term.bindings val intern_hyp : glob_sign -> identifier Util.located -> identifier Util.located @@ -118,28 +107,34 @@ val intern_hyp : val subst_genarg : substitution -> glob_generic_argument -> glob_generic_argument -val subst_rawconstr_and_expr : - substitution -> rawconstr_and_expr -> rawconstr_and_expr +val subst_glob_constr_and_expr : + substitution -> glob_constr_and_expr -> glob_constr_and_expr -(* Interprets any expression *) +val subst_glob_with_bindings : + substitution -> glob_constr_and_expr Glob_term.with_bindings -> glob_constr_and_expr Glob_term.with_bindings + +(** Interprets any expression *) val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value -(* Interprets an expression that evaluates to a constr *) +(** Interprets an expression that evaluates to a constr *) val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr -> constr -(* Interprets redexp arguments *) +(** Interprets redexp arguments *) val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> red_expr -(* Interprets tactic expressions *) +(** Interprets tactic expressions *) val interp_tac_gen : (identifier * value) list -> identifier list -> debug_info -> raw_tactic_expr -> tactic val interp_hyp : interp_sign -> goal sigma -> identifier located -> identifier -val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> rawconstr_and_expr Rawterm.bindings -> Evd.evar_map * constr Rawterm.bindings +val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr Glob_term.bindings -> Evd.evar_map * constr Glob_term.bindings + +val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map -> + glob_constr_and_expr Glob_term.with_bindings -> Evd.evar_map * constr Glob_term.with_bindings -(* Initial call for interpretation *) +(** Initial call for interpretation *) val glob_tactic : raw_tactic_expr -> glob_tactic_expr val glob_tactic_env : identifier list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr @@ -152,21 +147,18 @@ val eval_ltac_constr : goal sigma -> raw_tactic_expr -> constr val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr -(* Hides interpretation for pretty-print *) +(** Hides interpretation for pretty-print *) val hide_interp : raw_tactic_expr -> tactic option -> tactic -(* Declare the default tactic to fill implicit arguments *) -val declare_implicit_tactic : tactic -> unit - -(* Declare the xml printer *) +(** Declare the xml printer *) val declare_xml_printer : (out_channel -> Environ.env -> Evd.evar_map -> constr -> unit) -> unit -(* printing *) +(** printing *) val print_ltac : Libnames.qualid -> std_ppcmds -(* Internals that can be useful for syntax extensions. *) +(** Internals that can be useful for syntax extensions. *) exception CannotCoerceTo of string @@ -175,4 +167,3 @@ val interp_ltac_var : (value -> 'a) -> interp_sign -> Environ.env option -> iden val interp_int : interp_sign -> identifier located -> int val error_ltac_variable : loc -> identifier -> Environ.env option -> value -> string -> 'a - diff --git a/tactics/tactic_option.ml b/tactics/tactic_option.ml index df5a3283..57b8c540 100644 --- a/tactics/tactic_option.ml +++ b/tactics/tactic_option.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = declare_object { (default_object name) with cache_function = cache; diff --git a/tactics/tactic_option.mli b/tactics/tactic_option.mli index 890ba98e..8388738a 100644 --- a/tactics/tactic_option.mli +++ b/tactics/tactic_option.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let b = match dest_recarg recarg with | Norec | Imbr _ -> false - | Mrec j -> isrec & j=k + | Mrec (_,j) -> isrec & j=k in b :: (analrec c rest) | LetIn (_,_,_,c), rest -> false :: (analrec c rest) | _, [] -> [] @@ -367,7 +363,8 @@ let general_elim_then_using mk_elim match predicate with | None -> elimclause' | Some p -> - clenv_unify true Reduction.CONV (mkMeta pmv) p elimclause' + clenv_unify ~flags:Unification.elim_flags + Reduction.CONV (mkMeta pmv) p elimclause' in elim_res_pf_THEN_i elimclause' branchtacs gl diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 6466ab78..db9ab0c9 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* tactic val tclFAIL : int -> std_ppcmds -> tactic val tclFAIL_lazy : int -> std_ppcmds Lazy.t -> tactic val tclDO : int -> tactic -> tactic -val tclPROGRESS : tactic -> tactic val tclWEAK_PROGRESS : tactic -> tactic +val tclPROGRESS : tactic -> tactic val tclNOTSAMEGOAL : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclMAP : ('a -> tactic) -> 'a list -> tactic @@ -68,7 +64,7 @@ val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic val tclFIRST_PROGRESS_ON : ('a -> tactic) -> 'a list -> tactic -(*s Tacticals applying to hypotheses *) +(** {6 Tacticals applying to hypotheses } *) val onNthHypId : int -> (identifier -> tactic) -> tactic val onNthHyp : int -> (constr -> tactic) -> tactic @@ -96,14 +92,14 @@ val ifOnHyp : (identifier * types -> bool) -> val onHyps : (goal sigma -> named_context) -> (named_context -> tactic) -> tactic -(*s Tacticals applying to goal components *) +(** {6 Tacticals applying to goal components } *) -(* A [simple_clause] is a set of hypotheses, possibly extended with +(** A [simple_clause] is a set of hypotheses, possibly extended with the conclusion (conclusion is represented by None) *) type simple_clause = identifier option list -(* A [clause] denotes occurrences and hypotheses in a +(** A [clause] denotes occurrences and hypotheses in a goal; in particular, it can abstractly refer to the set of hypotheses independently of the effective contents of the current goal *) @@ -121,26 +117,25 @@ val tryAllHypsAndConcl : (identifier option -> tactic) -> tactic val onAllHyps : (identifier -> tactic) -> tactic val onAllHypsAndConcl : (identifier option -> tactic) -> tactic -val onAllHypsAndConclLR : (identifier option -> tactic) -> tactic val onClause : (identifier option -> tactic) -> clause -> tactic val onClauseLR : (identifier option -> tactic) -> clause -> tactic -(*s An intermediate form of occurrence clause with no mention of occurrences *) +(** {6 An intermediate form of occurrence clause with no mention of occurrences } *) -(* A [hyp_location] is an hypothesis together with a position, in +(** A [hyp_location] is an hypothesis together with a position, in body if any, in type or in both *) type hyp_location = identifier * hyp_location_flag -(* A [goal_location] is either an hypothesis (together with a position, in +(** A [goal_location] is either an hypothesis (together with a position, in body if any, in type or in both) or the goal *) type goal_location = hyp_location option -(*s A concrete view of occurrence clauses *) +(** {6 A concrete view of occurrence clauses } *) -(* [clause_atom] refers either to an hypothesis location (i.e. an +(** [clause_atom] refers either to an hypothesis location (i.e. an hypothesis with occurrences and a position, in body if any, in type or in both) or to some occurrences of the conclusion *) @@ -148,40 +143,40 @@ type clause_atom = | OnHyp of identifier * occurrences_expr * hyp_location_flag | OnConcl of occurrences_expr -(* A [concrete_clause] is an effective collection of +(** A [concrete_clause] is an effective collection of occurrences in the hypotheses and the conclusion *) type concrete_clause = clause_atom list -(* This interprets an [clause] in a given [goal] context *) +(** This interprets an [clause] in a given [goal] context *) val concrete_clause_of : clause -> goal sigma -> concrete_clause -(*s Elimination tacticals. *) +(** {6 Elimination tacticals. } *) type branch_args = { - ity : inductive; (* the type we were eliminating on *) - largs : constr list; (* its arguments *) - branchnum : int; (* the branch number *) - pred : constr; (* the predicate we used *) - nassums : int; (* the number of assumptions to be introduced *) - branchsign : bool list; (* the signature of the branch. + ity : inductive; (** the type we were eliminating on *) + largs : constr list; (** its arguments *) + branchnum : int; (** the branch number *) + pred : constr; (** the predicate we used *) + nassums : int; (** the number of assumptions to be introduced *) + branchsign : bool list; (** the signature of the branch. true=recursive argument, false=constant *) branchnames : intro_pattern_expr located list} type branch_assumptions = { - ba : branch_args; (* the branch args *) - assums : named_context} (* the list of assumptions introduced *) + ba : branch_args; (** the branch args *) + assums : named_context} (** the list of assumptions introduced *) -(* [check_disjunctive_pattern_size loc pats n] returns an appropriate *) -(* error message if |pats| <> n *) +(** [check_disjunctive_pattern_size loc pats n] returns an appropriate + error message if |pats| <> n *) val check_or_and_pattern_size : Util.loc -> or_and_intro_pattern_expr -> int -> unit -(* Tolerate "[]" to mean a disjunctive pattern of any length *) +(** Tolerate "[]" to mean a disjunctive pattern of any length *) val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr -> or_and_intro_pattern_expr -(* Useful for [as intro_pattern] modifier *) +(** Useful for [as intro_pattern] modifier *) val compute_induction_names : int -> intro_pattern_expr located option -> intro_pattern_expr located list array diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 186b5c48..988d9f53 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* !dependent_propositions_elimination) ; optwrite = (fun b -> dependent_propositions_elimination := b) } -let apply_in_side_conditions_come_first = ref true - -let use_apply_in_side_conditions_come_first () = - !apply_in_side_conditions_come_first - && Flags.version_strictly_greater Flags.V8_2 - -let _ = - declare_bool_option - { optsync = true; - optname = "apply-in side-conditions coming first"; - optkey = ["Side";"Conditions";"First";"For";"apply";"in"]; - optread = (fun () -> !dependent_propositions_elimination) ; - optwrite = (fun b -> dependent_propositions_elimination := b) } - +let finish_evar_resolution env initial_sigma c = + snd (Pretyping.solve_remaining_evars true true solve_by_implicit_tactic + env initial_sigma c) (*********************************************) (* Tactics *) @@ -165,7 +155,6 @@ let internal_cut_rev_replace = internal_cut_rev_gen true (* Moving hypotheses *) let move_hyp = Tacmach.move_hyp -let order_hyps = Tacmach.order_hyps (* Renaming hypotheses *) let rename_hyp = Tacmach.rename_hyp @@ -285,9 +274,12 @@ let reduct_in_hyp redfun (id,where) gl = convert_hyp_no_check (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl +let revert_cast (redfun,kind as r) = + if kind = DEFAULTcast then (redfun,REVERTcast) else r + let reduct_option redfun = function | Some id -> reduct_in_hyp (fst redfun) id - | None -> reduct_in_concl redfun + | None -> reduct_in_concl (revert_cast redfun) (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb t env sigma c = @@ -323,35 +315,25 @@ let change chg c cls gl = cls gl (* Pour usage interne (le niveau User est pris en compte par reduce) *) -let try_red_in_concl = reduct_in_concl (try_red_product,DEFAULTcast) -let red_in_concl = reduct_in_concl (red_product,DEFAULTcast) +let try_red_in_concl = reduct_in_concl (try_red_product,REVERTcast) +let red_in_concl = reduct_in_concl (red_product,REVERTcast) let red_in_hyp = reduct_in_hyp red_product -let red_option = reduct_option (red_product,DEFAULTcast) -let hnf_in_concl = reduct_in_concl (hnf_constr,DEFAULTcast) +let red_option = reduct_option (red_product,REVERTcast) +let hnf_in_concl = reduct_in_concl (hnf_constr,REVERTcast) let hnf_in_hyp = reduct_in_hyp hnf_constr -let hnf_option = reduct_option (hnf_constr,DEFAULTcast) -let simpl_in_concl = reduct_in_concl (simpl,DEFAULTcast) +let hnf_option = reduct_option (hnf_constr,REVERTcast) +let simpl_in_concl = reduct_in_concl (simpl,REVERTcast) let simpl_in_hyp = reduct_in_hyp simpl -let simpl_option = reduct_option (simpl,DEFAULTcast) -let normalise_in_concl = reduct_in_concl (compute,DEFAULTcast) +let simpl_option = reduct_option (simpl,REVERTcast) +let normalise_in_concl = reduct_in_concl (compute,REVERTcast) let normalise_in_hyp = reduct_in_hyp compute -let normalise_option = reduct_option (compute,DEFAULTcast) +let normalise_option = reduct_option (compute,REVERTcast) let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) -let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,DEFAULTcast) +let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast) let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast) -(* A function which reduces accordingly to a reduction expression, - as the command Eval does. *) - -let checking_fun = function - (* Expansion is not necessarily well-typed: e.g. expansion of t into x is - not well-typed in [H:(P t); x:=t |- G] because x is defined after H *) - | Fold _ -> with_check - | Pattern _ -> with_check - | _ -> (fun x -> x) - (* The main reduction function *) let reduction_clause redexp cl = @@ -433,31 +415,34 @@ let find_intro_names ctxt gl = ctxt (pf_env gl , []) in List.rev res -let build_intro_tac id = function - | MoveToEnd true -> introduction id - | dest -> tclTHEN (introduction id) (move_hyp true id dest) +let build_intro_tac id dest tac = match dest with + | MoveToEnd true -> tclTHEN (introduction id) (tac id) + | dest -> tclTHENLIST [introduction id; move_hyp true id dest; tac id] -let rec intro_gen loc name_flag move_flag force_flag dep_flag gl = +let rec intro_then_gen loc name_flag move_flag force_flag dep_flag tac gl = match kind_of_term (pf_concl gl) with | Prod (name,t,u) when not dep_flag or (dependent (mkRel 1) u) -> - build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag gl + build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag tac gl | LetIn (name,b,t,u) when not dep_flag or (dependent (mkRel 1) u) -> - build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag + build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag tac gl | _ -> if not force_flag then raise (RefinerError IntroNeedsProduct); try tclTHEN try_red_in_concl - (intro_gen loc name_flag move_flag force_flag dep_flag) gl + (intro_then_gen loc name_flag move_flag force_flag dep_flag tac) gl with Redelimination -> user_err_loc(loc,"Intro",str "No product even after head-reduction.") +let intro_gen loc n m f d = intro_then_gen loc n m f d (fun _ -> tclIDTAC) let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true false let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false false +let intro_then = intro_then_gen dloc (IntroAvoid []) no_move false false let intro = intro_gen dloc (IntroAvoid []) no_move false false let introf = intro_gen dloc (IntroAvoid []) no_move true false let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false false -let introf_move_name destopt = intro_gen dloc (IntroAvoid []) destopt true false + +let intro_then_force = intro_then_gen dloc (IntroAvoid []) no_move true false (**** Multiple introduction tactics ****) @@ -469,8 +454,13 @@ let intros = tclREPEAT intro let intro_erasing id = tclTHEN (thin [id]) (introduction id) -let intro_forthcoming_gen loc name_flag move_flag dep_flag = - tclREPEAT (intro_gen loc name_flag move_flag false dep_flag) +let intro_forthcoming_then_gen loc name_flag move_flag dep_flag tac = + let rec aux ids = + tclORELSE0 + (intro_then_gen loc name_flag move_flag false dep_flag + (fun id -> aux (id::ids))) + (tac ids) in + aux [] let rec get_next_hyp_position id = function | [] -> error ("No such hypothesis: " ^ string_of_id id) @@ -517,8 +507,8 @@ let intro_move idopt hto = match idopt with | Some id -> intro_gen dloc (IntroMustBe id) hto true false let pf_lookup_hypothesis_as_renamed env ccl = function - | AnonHyp n -> pf_lookup_index_as_renamed env ccl n - | NamedHyp id -> pf_lookup_name_as_displayed env ccl id + | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n + | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id let pf_lookup_hypothesis_as_renamed_gen red h gl = let env = pf_env gl in @@ -565,8 +555,13 @@ let intros_until = intros_until_gen true let intros_until_n = intros_until_n_gen true let intros_until_n_wored = intros_until_n_gen false +let tclCHECKVAR id gl = ignore (pf_get_hyp gl id); tclIDTAC gl + +let try_intros_until_id_check id = + tclORELSE (intros_until_id id) (tclCHECKVAR id) + let try_intros_until tac = function - | NamedHyp id -> tclTHEN (tclTRY (intros_until_id id)) (tac id) + | NamedHyp id -> tclTHEN (try_intros_until_id_check id) (tac id) | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHypId tac) let rec intros_move = function @@ -583,17 +578,32 @@ let dependent_in_decl a (_,c,t) = (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) +let onOpenInductionArg tac = function + | ElimOnConstr cbl -> + tac cbl + | ElimOnAnonHyp n -> + tclTHEN + (intros_until_n n) + (onLastHyp (fun c -> tac (Evd.empty,(c,NoBindings)))) + | ElimOnIdent (_,id) -> + (* A quantified hypothesis *) + tclTHEN + (try_intros_until_id_check id) + (tac (Evd.empty,(mkVar id,NoBindings))) + let onInductionArg tac = function - | ElimOnConstr (c,lbindc as cbl) -> - if isVar c & lbindc = NoBindings then - tclTHEN (tclTRY (intros_until_id (destVar c))) (tac cbl) - else - tac cbl + | ElimOnConstr cbl -> + tac cbl | ElimOnAnonHyp n -> tclTHEN (intros_until_n n) (onLastHyp (fun c -> tac (c,NoBindings))) | ElimOnIdent (_,id) -> - (*Identifier apart because id can be quantified in goal and not typable*) - tclTHEN (tclTRY (intros_until_id id)) (tac (mkVar id,NoBindings)) + (* A quantified hypothesis *) + tclTHEN (try_intros_until_id_check id) (tac (mkVar id,NoBindings)) + +let map_induction_arg f = function + | ElimOnConstr (sigma,(c,bl)) -> ElimOnConstr (f (sigma,c),bl) + | ElimOnAnonHyp n -> ElimOnAnonHyp n + | ElimOnIdent id -> ElimOnIdent id (**************************) (* Refinement tactics *) @@ -615,9 +625,9 @@ let bring_hyps hyps = let resolve_classes gl = let env = pf_env gl and evd = project gl in - if evd = Evd.empty then tclIDTAC gl + if Evd.is_empty evd then tclIDTAC gl else - let evd' = Typeclasses.resolve_typeclasses env (Evd.create_evar_defs evd) in + let evd' = Typeclasses.resolve_typeclasses env evd in (tclTHEN (tclEVARS evd') tclNORMEVAR) gl (**************************) @@ -723,24 +733,15 @@ let index_of_ind_arg t = | None -> error "Could not find inductive argument of elimination scheme." in aux None 0 t -let elim_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly = true; - modulo_delta = empty_transparent_state; - resolve_evars = false; - use_evars_pattern_unification = true; -} - -let elimination_clause_scheme with_evars allow_K 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 | _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed.")) in - let elimclause' = clenv_fchain ~flags:elim_flags indmv elimclause indclause in - res_pf elimclause' ~with_evars:with_evars ~allow_K:allow_K ~flags:elim_flags - gl + let elimclause' = clenv_fchain ~flags indmv elimclause indclause in + res_pf elimclause' ~with_evars:with_evars ~flags gl (* * Elimination tactic with bindings and using an arbitrary @@ -769,8 +770,8 @@ let general_elim_clause elimtac (c,lbindc) elim gl = let indclause = make_clenv_binding gl (c,t) lbindc in general_elim_clause_gen elimtac indclause elim gl -let general_elim with_evars c e ?(allow_K=true) = - general_elim_clause (elimination_clause_scheme with_evars allow_K) c e +let general_elim with_evars c e = + general_elim_clause (elimination_clause_scheme with_evars) c e (* Elimination tactic with bindings but using the default elimination * constant associated with the type. *) @@ -786,15 +787,15 @@ let default_elim with_evars (c,_ as cx) gl = let elim_in_context with_evars c = function | Some elim -> general_elim with_evars c {elimindex = Some (-1); elimbody = elim} - ~allow_K:true | None -> default_elim with_evars c let elim with_evars (c,lbindc as cx) elim = match kind_of_term c with | Var id when lbindc = NoBindings -> - tclTHEN (tclTRY (intros_until_id id)) + tclTHEN (try_intros_until_id_check id) (elim_in_context with_evars cx elim) - | _ -> elim_in_context with_evars cx elim + | _ -> + elim_in_context with_evars cx elim (* The simplest elimination tactic, with no substitutions at all. *) @@ -810,13 +811,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 elim_flags mv elimclause hypclause = - try clenv_fchain ~allow_K:false ~flags:elim_flags mv elimclause hypclause - with PretypeError (env,NoOccurrenceFound (op,_)) -> +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,NoOccurrenceFound (op,Some id))) + raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) -let elimination_in_clause_scheme with_evars 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 indmv (clenv_independent elimclause) with @@ -824,12 +825,11 @@ let elimination_in_clause_scheme with_evars id i elimclause indclause gl = | _ -> failwith "" with Failure _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed.") in - let elimclause' = clenv_fchain indmv elimclause indclause in + let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in let hyp_typ = pf_type_of gl hyp in let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in - let elimclause'' = - clenv_fchain_in id elim_flags hypmv elimclause' hypclause in + let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if eq_constr hyp_typ new_hyp_typ then errorlabstrm "general_rewrite_in" @@ -855,8 +855,8 @@ let general_case_analysis_in_context with_evars (c,lbindc) gl = let general_case_analysis with_evars (c,lbindc as cx) = match kind_of_term c with | Var id when lbindc = NoBindings -> - tclTHEN (tclTRY (intros_until_id id)) - (general_case_analysis_in_context with_evars cx) + tclTHEN (try_intros_until_id_check id) + (general_case_analysis_in_context with_evars cx) | _ -> general_case_analysis_in_context with_evars cx @@ -871,6 +871,7 @@ type conjunction_status = let make_projection sigma params cstr sign elim i n c = let elim = match elim with | NotADefinedRecordUseScheme elim -> + (* bugs: goes from right to left when i increases! *) let (na,b,t) = List.nth cstr.cs_args i in let b = match b with None -> mkRel (i+1) | Some b -> b in let branch = it_mkLambda_or_LetIn b cstr.cs_args in @@ -885,6 +886,7 @@ let make_projection sigma params cstr sign elim i n c = 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 @@ -919,7 +921,7 @@ let descend_in_conjunctions tac exit c gl = | Some (p,pt) -> tclTHENS (internal_cut id pt) - [refine_no_check p; + [refine p; (* Might be ill-typed due to forbidden elimination. *) tclTHEN (tac (not isrec) (mkVar id)) (thin [id])] gl) n) gl | None -> @@ -961,9 +963,9 @@ let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 = with PretypeError _|RefinerError _|UserError _|Failure _|Exit -> if with_destruct then descend_in_conjunctions - try_main_apply (fun _ -> Stdpp.raise_with_loc loc exn) c gl + try_main_apply (fun _ -> Loc.raise loc exn) c gl else - Stdpp.raise_with_loc loc exn + Loc.raise loc exn in try_red_apply thm_ty0 in try_main_apply with_destruct c gl0 @@ -1023,8 +1025,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 default_unify_flags else default_no_delta_unify_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 = @@ -1119,7 +1120,7 @@ let clear_wildcards ids = try with_check (Tacmach.thin_no_check [id]) gl with ClearDependencyError (id,err) -> (* Intercept standard [thin] error message *) - Stdpp.raise_with_loc loc + Loc.raise loc (error_clear_dependency (pf_env gl) (id_of_string "_") err)) ids @@ -1137,11 +1138,14 @@ let rec intros_clearing = function (* Modifying/Adding an hypothesis *) let specialize mopt (c,lbind) g = - let term = - if lbind = NoBindings then c + let tac, term = + if lbind = NoBindings then + let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in + tclEVARS evd, nf_evar evd c else let clause = make_clenv_binding g (c,pf_type_of g c) lbind in - let clause = clenv_unify_meta_types clause in + let flags = { default_unify_flags with resolve_evars = true } in + let clause = clenv_unify_meta_types ~flags clause in let (thd,tstack) = whd_stack clause.evd (clenv_value clause) in let nargs = List.length tstack in let tstack = match mopt with @@ -1158,16 +1162,18 @@ let specialize mopt (c,lbind) g = errorlabstrm "" (str "Cannot infer an instance for " ++ pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); - term + tclEVARS clause.evd, term in match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with | Var id when List.mem id (pf_ids_of_hyps g) -> - tclTHENFIRST + tclTHEN tac + (tclTHENFIRST (fun g -> internal_cut_replace id (pf_type_of g term) g) - (exact_no_check term) g - | _ -> tclTHENLAST - (fun g -> cut (pf_type_of g term) g) - (exact_no_check term) g + (exact_no_check term)) g + | _ -> tclTHEN tac + (tclTHENLAST + (fun g -> cut (pf_type_of g term) g) + (exact_no_check term)) g (* Keeping only a few hypotheses *) @@ -1245,12 +1251,20 @@ let simplest_split = split NoBindings (* Decomposing introductions *) (*****************************) +(* Rewriting function for rewriting one hypothesis at the time *) let forward_general_multi_rewrite = ref (fun _ -> failwith "general_multi_rewrite undefined") +(* Rewriting function for substitution (x=t) everywhere at the same time *) +let forward_subst_one = + ref (fun _ -> failwith "subst_one undefined") + let register_general_multi_rewrite f = forward_general_multi_rewrite := f +let register_subst_one f = + forward_subst_one := f + let error_unexpected_extra_pattern loc nb pat = let s1,s2,s3 = match pat with | IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no" @@ -1284,6 +1298,8 @@ let intro_or_and_pattern loc b ll l' tac id gl = let rewrite_hyp l2r id gl = let rew_on l2r = !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) in + let subst_on l2r x rhs = + !forward_subst_one true x (id,rhs,l2r) in let clear_var_and_eq c = tclTRY (tclTHEN (clear [id]) (tclTRY (clear [destVar c]))) in let t = pf_whd_betadeltaiota gl (pf_type_of gl (mkVar id)) in @@ -1291,9 +1307,9 @@ let rewrite_hyp l2r id gl = match match_with_equality_type t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r & isVar lhs & not (occur_var (pf_env gl) (destVar lhs) rhs) then - tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq lhs) gl + subst_on l2r (destVar lhs) rhs gl else if not l2r & isVar rhs & not (occur_var (pf_env gl) (destVar rhs) lhs) then - tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq rhs) gl + subst_on l2r (destVar rhs) lhs gl else tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl | Some (hdcncl,[c]) -> @@ -1315,57 +1331,65 @@ let rec explicit_intro_names = function | [] -> [] +let wild_id = id_of_string "_tmp" + +let rec list_mem_assoc_right id = function + | [] -> false + | (x,id')::l -> id = id' || list_mem_assoc_right id l + +let check_thin_clash_then id thin avoid tac = + if list_mem_assoc_right id thin then + let newid = next_ident_away (add_suffix id "'") avoid in + let thin = + List.map (on_snd (fun id' -> if id = id' then newid else id')) thin in + tclTHEN (rename_hyp [id,newid]) (tac thin) + else + tac thin + (* We delay thinning until the completion of the whole intros tactic to ensure that dependent hypotheses are cleared in the right dependency order (see bug #1000); we use fresh names, not used in the tactic, for the hyps to clear *) -let rec intros_patterns b avoid thin destopt = function +let rec intros_patterns b avoid ids thin destopt tac = function | (loc, IntroWildcard) :: l -> - tclTHEN - (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) - no_move true false) - (onLastHypId (fun id -> - tclORELSE - (tclTHEN (clear [id]) (intros_patterns b avoid thin destopt l)) - (intros_patterns b avoid ((loc,id)::thin) destopt l))) + intro_then_gen loc (IntroBasedOn(wild_id,avoid@explicit_intro_names l)) + no_move true false + (fun id -> intros_patterns b avoid ids ((loc,id)::thin) destopt tac l) | (loc, IntroIdentifier id) :: l -> - tclTHEN - (intro_gen loc (IntroMustBe id) destopt true false) - (intros_patterns b avoid thin destopt l) + check_thin_clash_then id thin avoid (fun thin -> + intro_then_gen loc (IntroMustBe id) destopt true false + (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l)) | (loc, IntroAnonymous) :: l -> - tclTHEN - (intro_gen loc (IntroAvoid (avoid@explicit_intro_names l)) - destopt true false) - (intros_patterns b avoid thin destopt l) + intro_then_gen loc (IntroAvoid (avoid@explicit_intro_names l)) + destopt true false + (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l) | (loc, IntroFresh id) :: l -> - tclTHEN - (intro_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l)) - destopt true false) - (intros_patterns b avoid thin destopt l) + (* todo: avoid thinned names to interfere with generation of fresh name *) + intro_then_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l)) + destopt true false + (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l) | (loc, IntroForthcoming onlydeps) :: l -> - tclTHEN - (intro_forthcoming_gen loc (IntroAvoid (avoid@explicit_intro_names l)) - destopt onlydeps) - (intros_patterns b avoid thin destopt l) + intro_forthcoming_then_gen loc (IntroAvoid (avoid@explicit_intro_names l)) + destopt onlydeps + (fun ids -> intros_patterns b avoid ids thin destopt tac l) | (loc, IntroOrAndPattern ll) :: l' -> - tclTHEN - introf - (onLastHypId - (intro_or_and_pattern loc b ll l' - (intros_patterns b avoid thin destopt))) + intro_then_force + (intro_or_and_pattern loc b ll l' + (intros_patterns b avoid ids thin destopt tac)) | (loc, IntroRewrite l2r) :: l -> - tclTHEN - (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) - no_move true false) - (onLastHypId (fun id -> + intro_then_gen loc (IntroAvoid(avoid@explicit_intro_names l)) + no_move true false + (fun id -> tclTHENLAST (* Skip the side conditions of the rewriting step *) (rewrite_hyp l2r id) - (intros_patterns b avoid thin destopt l))) - | [] -> clear_wildcards thin + (intros_patterns b avoid ids thin destopt tac l)) + | [] -> tac ids thin -let intros_pattern = intros_patterns false [] [] +let intros_pattern destopt = + intros_patterns false [] [] [] destopt (fun _ -> clear_wildcards) -let intro_pattern destopt pat = intros_patterns false [] [] destopt [dloc,pat] +let intro_pattern destopt pat = + intros_pattern destopt [dloc,pat] let intro_patterns = function | [] -> tclREPEAT intro @@ -1390,7 +1414,7 @@ let prepare_intros s ipat gl = match ipat with | IntroOrAndPattern ll -> make_id s gl, onLastHypId (intro_or_and_pattern loc true ll [] - (intros_patterns true [] [] no_move)) + (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards))) | IntroForthcoming _ -> user_err_loc (loc,"",str "Introduction pattern for one hypothesis expected") @@ -1400,7 +1424,8 @@ let ipat_of_name = function let allow_replace c gl = function (* A rather arbitrary condition... *) | Some (_, IntroIdentifier id) -> - fst (decompose_app ((strip_lam_assum c))) = mkVar id + let c = fst (decompose_app ((strip_lam_assum c))) in + isVar c && destVar c = id | _ -> false @@ -1422,7 +1447,8 @@ let as_tac id ipat = match ipat with | Some (loc,IntroRewrite l2r) -> !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl | Some (loc,IntroOrAndPattern ll) -> - intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move) + intro_or_and_pattern loc true ll [] + (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards)) id | Some (loc, (IntroIdentifier _ | IntroAnonymous | IntroFresh _ | @@ -1484,7 +1510,7 @@ let generalize_goal gl i ((occs,c,b),na) cl = 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_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in + let cl' = subst_closed_term_occ 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' @@ -1659,14 +1685,48 @@ let letin_tac with_eq name c occs gl = (* Implementation without generalisation: abbrev will be lost in hyps in *) (* in the extracted proof *) -let letin_abstract id c (occs,check_occs) gl = +let default_matching_flags sigma = { + modulo_conv_on_closed_terms = Some empty_transparent_state; + use_metas_eagerly_in_conv_on_closed_terms = false; + modulo_delta = empty_transparent_state; + modulo_delta_types = full_transparent_state; + check_applied_meta_types = true; + resolve_evars = false; + use_pattern_unification = false; + use_meta_bound_pattern_unification = false; + frozen_evars = + fold_undefined (fun evk _ evars -> ExistentialSet.add evk evars) + sigma ExistentialSet.empty; + restrict_conv_on_strict_subterms = false; + modulo_betaiota = false; + modulo_eta = false; + allow_K_in_toplevel_higher_order_unification = false +} + +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) + with _ -> 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 + { 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) + +let letin_abstract id c (test,out) (occs,check_occs) gl = let env = pf_env gl in let compute_dependency _ (hyp,_,_ as d) depdecls = match occurrences_of_hyp hyp occs with | None -> depdecls | Some occ -> - let newdecl = subst_term_occ_decl occ c d in - if occ = (all_occurrences,InHyp) & d = newdecl then + let newdecl = subst_closed_term_occ_decl_modulo occ test d in + if occ = (all_occurrences,InHyp) & eq_named_declaration d newdecl then if check_occs & not (in_every_hyp occs) then raise (RefinerError (DoesNotOccurIn (c,hyp))) else depdecls @@ -1675,19 +1735,21 @@ let letin_abstract id c (occs,check_occs) gl = let depdecls = fold_named_context compute_dependency env ~init:[] in let ccl = match occurrences_of_goal occs with | None -> pf_concl gl - | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) in + | Some occ -> + subst1 (mkVar id) (subst_closed_term_occ_modulo occ test None (pf_concl gl)) in let lastlhyp = if depdecls = [] then no_move else MoveAfter(pi1(list_last depdecls)) in - (depdecls,lastlhyp,ccl) + (depdecls,lastlhyp,ccl,out test) -let letin_tac_gen with_eq name c ty occs gl = +let letin_tac_gen with_eq name (sigmac,c) test ty occs gl = let id = - let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in + let t = match ty with Some t -> t | None -> typ_of (pf_env gl) sigmac c in + let x = id_of_name_using_hdchar (Global.env()) t name in if name = Anonymous then fresh_id [] x gl else if not (mem_named_context x (pf_hyps gl)) then x else error ("The variable "^(string_of_id x)^" is already declared.") in - let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in - let t = match ty with Some t -> t | None -> pf_type_of gl c in + let (depdecls,lastlhyp,ccl,c) = letin_abstract id c test occs gl in + let t = match ty with Some t -> t | None -> pf_apply typ_of gl c in let newcl,eq_tac = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with @@ -1711,8 +1773,15 @@ let letin_tac_gen with_eq name c ty occs gl = tclMAP convert_hyp_no_check depdecls; eq_tac ] gl -let letin_tac with_eq name c ty occs = - letin_tac_gen with_eq name c ty (occs,true) +let make_eq_test c = (make_eq_test c,fun _ -> c) + +let letin_tac with_eq name c ty occs gl = + letin_tac_gen with_eq name (project gl,c) (make_eq_test c) ty (occs,true) gl + +let letin_pat_tac with_eq name c ty occs gl = + letin_tac_gen with_eq name c + (make_pattern_test (pf_env gl) (project gl) c) + ty (occs,true) gl (* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *) let forward usetac ipat c gl = @@ -1755,6 +1824,9 @@ let unfold_all x gl = if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else tclIDTAC gl +(* Either unfold and clear if defined or simply clear if not a definition *) +let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id]) + (*****************************) (* High-level induction *) (*****************************) @@ -1797,16 +1869,6 @@ let check_unused_names names = (str"Unused introduction " ++ str (plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc pr_intro_pattern names) -let rec first_name_buggy avoid gl (loc,pat) = match pat with - | IntroOrAndPattern [] -> no_move - | IntroOrAndPattern ([]::l) -> - first_name_buggy avoid gl (loc,IntroOrAndPattern l) - | IntroOrAndPattern ((p::_)::_) -> first_name_buggy avoid gl p - | IntroWildcard -> no_move - | IntroRewrite _ -> no_move - | IntroIdentifier id -> MoveAfter id - | IntroAnonymous | IntroFresh _ | IntroForthcoming _ -> (* buggy *) no_move - let rec consume_pattern avoid id isdep gl = function | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), []) | (loc,IntroAnonymous)::names -> @@ -1822,7 +1884,8 @@ let rec consume_pattern avoid id isdep gl = function ((loc,IntroIdentifier (fresh_id avoid id' gl)), names) | pat::names -> (pat,names) -let re_intro_dependent_hypotheses (lstatus,rstatus) tophyp = +let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) = + let tophyp = match tophyp with None -> MoveToEnd true | Some hyp -> MoveAfter hyp in let newlstatus = (* if some IH has taken place at the top of hyps *) List.map (function (hyp,MoveToEnd true) -> (hyp,tophyp) | x -> x) lstatus in @@ -1832,20 +1895,46 @@ let re_intro_dependent_hypotheses (lstatus,rstatus) tophyp = let update destopt tophyp = if destopt = no_move then tophyp else destopt -let safe_dest_intros_patterns avoid dest pat gl = - try intros_patterns true avoid [] dest pat gl +let safe_dest_intros_patterns avoid thin dest pat tac gl = + try intros_patterns true avoid [] thin dest tac pat gl with UserError ("move_hyp",_) -> - (* May happen if the lemma has dependent arguments that has resolved - only after cook_sign is called, e.g. as in + (* May happen if the lemma has dependent arguments that are resolved + only after cook_sign is called, e.g. as in "destruct dec" in context "dec:forall x, {x=0}+{x<>0}; a:A |- if dec a then True else False" - for argument a of dec which will be found only lately *) - intros_patterns true avoid [] no_move pat gl + where argument a of dec will be found only lately *) + intros_patterns true avoid [] [] no_move tac pat gl type elim_arg_kind = RecArg | IndArg | OtherArg -let induct_discharge destopt avoid' tac (avoid,ra) names gl = +type recarg_position = + | AfterFixedPosition of identifier option (* None = top of context *) + +let update_dest (recargdests,tophyp as dests) = function + | [] -> dests + | hyp::_ -> + (match recargdests with + | AfterFixedPosition None -> AfterFixedPosition (Some hyp) + | x -> x), + (match tophyp with None -> Some hyp | x -> x) + +let get_recarg_dest (recargdests,tophyp) = + match recargdests with + | AfterFixedPosition None -> MoveToEnd true + | AfterFixedPosition (Some id) -> MoveAfter id + +(* Current policy re-introduces recursive arguments of destructed + variable at the place of the original variable while induction + hypothesese are introduced at the top of the context. Since in the + general case of an inductive scheme, the induction hypotheses can + arrive just after the recursive arguments (e.g. as in "forall + t1:tree, P t1 -> forall t2:tree, P t2 -> P (node t1 t2)", we need + to update the position for t2 after "P t1" is introduced if ever t2 + had to be introduced at the top of the context). +*) + +let induct_discharge dests avoid' tac (avoid,ra) names gl = let avoid = avoid @ avoid' in - let rec peel_tac ra names tophyp gl = + let rec peel_tac ra dests names thin gl = match ra with | (RecArg,deprec,recvarname) :: (IndArg,depind,hyprecname) :: ra' -> @@ -1855,37 +1944,33 @@ let induct_discharge destopt avoid' tac (avoid,ra) names gl = (pat, [dloc, IntroIdentifier id']) | _ -> consume_pattern avoid recvarname deprec gl names in let hyprec,names = consume_pattern avoid hyprecname depind gl names in - (* IH stays at top: we need to update tophyp *) - (* This is buggy for intro-or-patterns with different first hypnames *) - (* Would need to pass peel_tac as a continuation of intros_patterns *) - (* (or to have hypotheses classified by blocks...) *) - let newtophyp = - if tophyp=no_move then first_name_buggy avoid gl hyprec else tophyp - in - tclTHENLIST - [ safe_dest_intros_patterns avoid (update destopt tophyp) [recpat]; - safe_dest_intros_patterns avoid no_move [hyprec]; - peel_tac ra' names newtophyp] gl + let dest = get_recarg_dest dests in + safe_dest_intros_patterns avoid thin dest [recpat] (fun ids thin -> + safe_dest_intros_patterns avoid thin no_move [hyprec] (fun ids' thin -> + peel_tac ra' (update_dest dests ids') names thin)) + gl | (IndArg,dep,hyprecname) :: ra' -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = consume_pattern avoid hyprecname dep gl names in - tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat]) - (peel_tac ra' names tophyp) gl + safe_dest_intros_patterns avoid thin no_move [pat] (fun ids thin -> + peel_tac ra' (update_dest dests ids) names thin) gl | (RecArg,dep,recvarname) :: ra' -> let pat,names = consume_pattern avoid recvarname dep gl names in - tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat]) - (peel_tac ra' names tophyp) gl + let dest = get_recarg_dest dests in + safe_dest_intros_patterns avoid thin dest [pat] (fun ids thin -> + peel_tac ra' dests names thin) gl | (OtherArg,_,_) :: ra' -> let pat,names = match names with | [] -> (dloc, IntroAnonymous), [] | pat::names -> pat,names in - tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat]) - (peel_tac ra' names tophyp) gl + let dest = get_recarg_dest dests in + safe_dest_intros_patterns avoid thin dest [pat] (fun ids thin -> + peel_tac ra' dests names thin) gl | [] -> check_unused_names names; - tac tophyp gl + tclTHEN (clear_wildcards thin) (tac dests) gl in - peel_tac ra names no_move gl + peel_tac ra dests names [] gl (* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas s'embêter à regarder si un letin_tac ne fait pas des @@ -2063,8 +2148,13 @@ let cook_sign hyp0_opt indvars env = fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in raise (Shunt (MoveToEnd true)) (* ?? FIXME *) with Shunt lhyp0 -> + let lhyp0 = match lhyp0 with + | MoveToEnd true -> None + | MoveAfter hyp -> Some hyp + | _ -> assert false in let statuslists = (!lstatus,List.rev !rstatus) in - (statuslists, (if hyp0_opt=None then MoveToEnd true else lhyp0), + let recargdests = AfterFixedPosition (if hyp0_opt=None then None else lhyp0) in + (statuslists, (recargdests,None), !indhyps, !decldeps) @@ -2167,23 +2257,6 @@ let make_up_names n ind_opt cname = else avoid in id_of_string base, hyprecname, avoid -let is_indhyp p n t = - let l, c = decompose_prod t in - let c,_ = decompose_app c in - let p = p + List.length l in - match kind_of_term c with - | Rel k when p < k & k <= p + n -> true - | _ -> false - -let chop_context n l = - let rec chop_aux acc = function - | n, (_,Some _,_ as h :: t) -> chop_aux (h::acc) (n, t) - | 0, l2 -> (List.rev acc, l2) - | n, (h::t) -> chop_aux (h::acc) (n-1, t) - | _, [] -> anomaly "chop_context" - in - chop_aux [] (n,l) - let error_ind_scheme s = let s = if s <> "" then s^" " else s in error ("Cannot recognize "^s^"an induction scheme.") @@ -2194,8 +2267,6 @@ let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.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 coq_block = lazy (Coqlib.coq_constant "tactics" ["Program";"Equality"] "block") - let mkEq t x y = mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |]) @@ -2218,8 +2289,6 @@ let lift_togethern n l = l ([], n) in l' -let lift_together l = lift_togethern 0 l - let lift_list l = List.map (lift 1) l let ids_of_constr ?(all=false) vars c = @@ -2267,11 +2336,11 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls = in (* Abstract by equalitites *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) - let abseqs = it_mkProd_or_LetIn ~init:(lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in + let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in (* Abstract by the "generalized" hypothesis. *) let genarg = mkProd_or_LetIn (Name id, body, c) abseqs in (* Abstract by the extension of the context *) - let genctyp = it_mkProd_or_LetIn ~init:genarg ctx in + let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in (* Apply the old arguments giving the proper instantiation of the hyp *) @@ -2282,17 +2351,6 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls = let appeqs = mkApp (instc, Array.of_list refls) in (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) mkApp (appeqs, abshypt) - -let deps_of_var id env = - Environ.fold_named_context - (fun _ (n,b,t) (acc : Idset.t) -> - if Option.cata (occur_var env id) false b || occur_var env id t then - Idset.add n acc - else acc) - env ~init:Idset.empty - -let idset_of_list = - List.fold_left (fun s x -> Idset.add x s) Idset.empty let hyps_of_vars env sign nogen hyps = if Idset.is_empty hyps then [] @@ -2311,6 +2369,23 @@ let hyps_of_vars env sign nogen hyps = sign in lh +exception Seen + +let linear vars args = + let seen = ref vars in + try + Array.iter (fun i -> + let rels = ids_of_constr ~all:true Idset.empty i in + let seen' = + Idset.fold (fun id acc -> + if Idset.mem id acc then raise Seen + else Idset.add id acc) + rels !seen + in seen := seen') + args; + true + with Seen -> false + let is_defined_variable env id = pi2 (lookup_named id env) <> None @@ -2337,6 +2412,7 @@ let abstract_args gl generalize_vars dep id defined f args = in let argty = pf_type_of gl arg in let argty = refresh_universes_strict argty 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 @@ -2364,23 +2440,19 @@ let abstract_args gl generalize_vars dep id defined f args = nongenvars, Idset.union argvars vars, env) in let f', args' = decompose_indapp f args in - let parvars = ids_of_constr ~all:true Idset.empty f' in - let seen = ref parvars in let dogen, f', args' = - let find i x = not (isVar x) || - let v = destVar x in - if is_defined_variable env v || Idset.mem v !seen then true - else (seen := Idset.add v !seen; false) - in - match array_find_i find args' with - | None -> false, f', args' - | Some nonvar -> - let before, after = array_chop nonvar args' in - true, mkApp (f', before), after + let parvars = ids_of_constr ~all:true Idset.empty f' in + if not (linear parvars args') then true, f, args + else + match array_find_i (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with + | None -> false, f', args' + | Some nonvar -> + let before, after = array_chop nonvar args' in + true, mkApp (f', before), after in if dogen then - let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = - Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],!seen,Idset.empty,env) args' + let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = + Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Idset.empty,Idset.empty,env) args' in let args, refls = List.rev args, List.rev refls in let vars = @@ -2389,7 +2461,7 @@ let abstract_args gl generalize_vars dep id defined f args = hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars else [] in - let body, c' = if defined then Some c', Retyping.get_type_of ctxenv Evd.empty c' else None, c' in + let body, c' = if defined then Some c', typ_of ctxenv Evd.empty c' else None, c' in Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls, dep, succ (List.length ctx), vars) else None @@ -2429,20 +2501,20 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id gl = let specialize_eqs id gl = let env = pf_env gl in let ty = pf_get_hyp_typ gl id in - let evars = ref (create_evar_defs (project gl)) in + let evars = ref (project gl) in let unif env evars c1 c2 = Evarconv.e_conv env evars c2 c1 in let rec aux in_eqs ctx acc ty = match kind_of_term ty with | Prod (na, t, b) -> (match kind_of_term t with - | App (eq, [| eqty; x; y |]) when in_eqs && eq_constr eq (Lazy.force coq_eq) -> + | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_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 if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty - | App (heq, [| eqty; x; eqty'; y |]) when in_eqs && eq_constr heq (Lazy.force coq_heq) -> + | App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) -> let eqt, c = if noccur_between 1 (List.length ctx) x then eqty', y else eqty, x in let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in @@ -2454,10 +2526,8 @@ let specialize_eqs id gl = else let e = e_new_evar evars (push_rel_context ctx env) t in aux false ((na, Some e, t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) - | App (f, args) when eq_constr f (Lazy.force coq_block) && not in_eqs -> - aux true ctx acc args.(1) | t -> acc, in_eqs, ctx, ty - in + in let acc, worked, ctx, ty = aux false [] (mkVar id) ty in let ctx' = nf_rel_context_evar !evars ctx in let ctx'' = List.map (fun (n,b,t as decl) -> @@ -2485,33 +2555,6 @@ let occur_rel n c = let res = not (noccurn n c) in res -let list_filter_firsts f l = - let rec list_filter_firsts_aux f acc l = - match l with - | e::l' when f e -> list_filter_firsts_aux f (acc@[e]) l' - | _ -> acc,l - in - list_filter_firsts_aux f [] l - -let count_rels_from n c = - let rels = free_rels c in - let cpt,rg = ref 0, ref n in - while Intset.mem !rg rels do - cpt:= !cpt+1; rg:= !rg+1; - done; - !cpt - -let count_nonfree_rels_from n c = - let rels = free_rels c in - if Intset.exists (fun x -> x >= n) rels then - let cpt,rg = ref 0, ref n in - while not (Intset.mem !rg rels) do - cpt:= !cpt+1; rg:= !rg+1; - done; - !cpt - else raise Not_found - - (* cuts a list in two parts, first of size n. Size must be greater than n *) let cut_list n l = let rec cut_list_aux acc n l = @@ -2671,83 +2714,62 @@ let compute_elim_sig ?elimc elimt = let compute_scheme_signature scheme names_info ind_type_guess = let f,l = decompose_app scheme.concl in (* Vérifier que les arguments de Qi sont bien les xi. *) - match scheme.indarg with - | Some (_,Some _,_) -> error "Strange letin, cannot recognize an induction scheme." - | None -> (* Non standard scheme *) - let is_pred n c = - let hd = fst (decompose_app c) in match kind_of_term hd with - | Rel q when n < q & q <= n+scheme.npredicates -> IndArg - | _ when hd = ind_type_guess & not scheme.farg_in_concl -> RecArg - | _ -> OtherArg in - let rec check_branch p c = - match kind_of_term c with - | Prod (_,t,c) -> - (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c - | LetIn (_,_,_,c) -> - (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c - | _ when is_pred p c = IndArg -> [] - | _ -> raise Exit in - let rec find_branches p lbrch = - match lbrch with - | (_,None,t)::brs -> - (try - let lchck_brch = check_branch p t in - let n = List.fold_left - (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in - let recvarname, hyprecname, avoid = - make_up_names n scheme.indref names_info in - let namesign = - List.map (fun (b,dep) -> - (b,dep,if b=IndArg then hyprecname else recvarname)) - lchck_brch in - (avoid,namesign) :: find_branches (p+1) brs - with Exit-> error_ind_scheme "the branches of") - | (_,Some _,_)::_ -> error_ind_scheme "the branches of" - | [] -> [] in - Array.of_list (find_branches 0 (List.rev scheme.branches)) - - | Some ( _,None,ind) -> (* Standard scheme from an inductive type *) - let indhd,indargs = decompose_app ind in - let is_pred n c = - let hd = fst (decompose_app c) in match kind_of_term hd with - | Rel q when n < q & q <= n+scheme.npredicates -> IndArg - | _ when hd = indhd -> RecArg - | _ -> OtherArg in - let rec check_branch p c = match kind_of_term c with - | Prod (_,t,c) -> - (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c - | LetIn (_,_,_,c) -> - (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c - | _ when is_pred p c = IndArg -> [] - | _ -> raise Exit in - let rec find_branches p lbrch = - match lbrch with - | (_,None,t)::brs -> - (try - let lchck_brch = check_branch p t in - let n = List.fold_left - (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in - let recvarname, hyprecname, avoid = - make_up_names n scheme.indref names_info in - let namesign = - List.map (fun (b,dep) -> - (b,dep,if b=IndArg then hyprecname else recvarname)) - lchck_brch in - (avoid,namesign) :: find_branches (p+1) brs - with Exit -> error_ind_scheme "the branches of") - | (_,Some _,_)::_ -> error_ind_scheme "the branches of" - | [] -> - (* Check again conclusion *) - - let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in - let ind_is_ok = - list_lastn scheme.nargs indargs - = extended_rel_list 0 scheme.args in - if not (ccl_arg_ok & ind_is_ok) then - error_ind_scheme "the conclusion of"; - [] - in - Array.of_list (find_branches 0 (List.rev scheme.branches)) + let cond, check_concl = + match scheme.indarg with + | Some (_,Some _,_) -> + error "Strange letin, cannot recognize an induction scheme." + | None -> (* Non standard scheme *) + let cond hd = eq_constr hd ind_type_guess && not scheme.farg_in_concl + in (cond, fun _ _ -> ()) + | Some ( _,None,ind) -> (* Standard scheme from an inductive type *) + let indhd,indargs = decompose_app ind in + let cond hd = eq_constr hd indhd in + let check_concl is_pred p = + (* Check again conclusion *) + let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in + let ind_is_ok = + list_equal eq_constr + (list_lastn scheme.nargs indargs) + (extended_rel_list 0 scheme.args) in + if not (ccl_arg_ok & ind_is_ok) then + error_ind_scheme "the conclusion of" + in (cond, check_concl) + in + let is_pred n c = + let hd = fst (decompose_app c) in + match kind_of_term hd with + | Rel q when n < q & q <= n+scheme.npredicates -> IndArg + | _ when cond hd -> RecArg + | _ -> OtherArg + in + let rec check_branch p c = + match kind_of_term c with + | Prod (_,t,c) -> + (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c + | LetIn (_,_,_,c) -> + (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c + | _ when is_pred p c = IndArg -> [] + | _ -> raise Exit + in + let rec find_branches p lbrch = + match lbrch with + | (_,None,t)::brs -> + (try + let lchck_brch = check_branch p t in + let n = List.fold_left + (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in + let recvarname, hyprecname, avoid = + make_up_names n scheme.indref names_info in + let namesign = + List.map (fun (b,dep) -> + (b,dep,if b=IndArg then hyprecname else recvarname)) + lchck_brch in + (avoid,namesign) :: find_branches (p+1) brs + with Exit-> error_ind_scheme "the branches of") + | (_,Some _,_)::_ -> error_ind_scheme "the branches of" + | [] -> check_concl is_pred p; [] + in + Array.of_list (find_branches 0 (List.rev scheme.branches)) (* Check that the elimination scheme has a form similar to the elimination schemes built by Coq. Schemes may have the standard @@ -2885,7 +2907,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 true 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 @@ -2895,7 +2917,9 @@ let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names t let isrec, elim, indsign = get_eliminator elim gl in let names = compute_induction_names (Array.length indsign) names in (if isrec then tclTHENFIRSTn else tclTHENLASTn) - (tclTHEN (induct_tac elim) (tclTRY (thin indhyps))) + (tclTHEN + (induct_tac elim) + (tclMAP (fun id -> tclTRY (expand_hyp id)) (List.rev indhyps))) (array_map2 (induct_discharge destopt avoid tac) indsign names) gl (* Apply induction "in place" taking into account dependent @@ -2979,7 +3003,7 @@ let induction_tac with_evars elim (varname,lbind) typ gl = let elimclause = make_clenv_binding gl (mkCast (elimc,DEFAULTcast,elimt),elimt) lbindelimc in - elimination_clause_scheme with_evars true i elimclause indclause gl + elimination_clause_scheme with_evars i elimclause indclause gl let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) names inhyps gl = @@ -3017,14 +3041,6 @@ let induction_without_atomization isrec with_evars elim names lid gl = then error "Not the right number of induction arguments." else induction_from_context_l with_evars elim_info lid names gl -let enforce_eq_name id gl = function - | (b,(loc,IntroAnonymous)) -> - (b,(loc,IntroIdentifier (fresh_id [id] (add_prefix "Heq" id) gl))) - | (b,(loc,IntroFresh heq_base)) -> - (b,(loc,IntroIdentifier (fresh_id [id] heq_base gl))) - | x -> - x - let has_selected_occurrences = function | None -> false | Some cls -> @@ -3054,7 +3070,7 @@ let clear_unselected_context id inhyps cls gl = thin ids gl | None -> tclIDTAC gl -let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl = +let new_induct_gen isrec with_evars elim (eqname,names) (sigma,(c,lbind)) cls gl = let inhyps = match cls with | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps | _ -> [] in @@ -3067,14 +3083,17 @@ let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl = (induction_with_atomization_of_ind_arg isrec with_evars elim names (id,lbind) inhyps) gl | _ -> - let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) + let x = id_of_name_using_hdchar (Global.env()) (typ_of (pf_env gl) sigma c) Anonymous in let id = fresh_id [] x gl in (* We need the equality name now *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) tclTHEN - (letin_tac_gen with_eq (Name id) c None (Option.default allHypsAndConcl cls,false)) + (* Warning: letin is buggy when c is not of inductive type *) + (letin_tac_gen with_eq (Name id) (sigma,c) + (make_pattern_test (pf_env gl) (project gl) (sigma,c)) + None (Option.default allHypsAndConcl cls,false)) (induction_with_atomization_of_ind_arg isrec with_evars elim names (id,lbind) inhyps) gl @@ -3131,7 +3150,7 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) gl = assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *) if List.length lc = 1 && not (is_functional_induction elim gl) then (* standard induction *) - onInductionArg + onOpenInductionArg (fun c -> new_induct_gen isrec with_evars elim names c cls) (List.hd lc) gl else begin @@ -3143,6 +3162,8 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) gl = str "Example: induction x1 x2 x3 using my_scheme."); if cls <> None then error "'in' clause not supported here."; + let lc = List.map + (map_induction_arg (pf_apply finish_evar_resolution gl)) lc in if List.length lc = 1 then (* Hook to recover standard induction on non-standard induction schemes *) (* will be removable when is_functional_induction will be more clever *) @@ -3150,8 +3171,7 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) gl = (fun (c,lbind) -> if lbind <> NoBindings then error "'with' clause not supported here."; - new_induct_gen_l isrec with_evars elim names [c]) - (List.hd lc) gl + new_induct_gen_l isrec with_evars elim names [c]) (List.hd lc) gl else let newlc = List.map (fun x -> @@ -3179,11 +3199,8 @@ let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls) (* Induction tactics *) (* This was Induction before 6.3 (induction only in quantified premisses) *) -let raw_induct s = tclTHEN (intros_until_id s) (onLastHyp simplest_elim) -let raw_induct_nodep n = tclTHEN (intros_until_n n) (onLastHyp simplest_elim) - -let simple_induct_id hyp = raw_induct hyp -let simple_induct_nodep = raw_induct_nodep +let simple_induct_id s = tclTHEN (intros_until_id s) (onLastHyp simplest_elim) +let simple_induct_nodep n = tclTHEN (intros_until_n n) (onLastHyp simplest_elim) let simple_induct = function | NamedHyp id -> simple_induct_id id @@ -3213,9 +3230,9 @@ let elim_scheme_type elim t gl = | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) - clenv_unify true Reduction.CUMUL t + clenv_unify ~flags:elim_flags Reduction.CUMUL t (clenv_meta_type clause mv) clause in - res_pf clause' ~allow_K:true gl + res_pf clause' ~flags:elim_flags gl | _ -> anomaly "elim_scheme_type" let elim_type t gl = @@ -3472,7 +3489,7 @@ let abstract_subproof id tac gl = let const = Pfedit.build_constant_by_tactic id secsign concl (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)) in let cd = Entries.DefinitionEntry const in - let lem = mkConst (Declare.declare_internal_constant id (cd,IsProof Lemma)) in + let lem = mkConst (Declare.declare_constant ~internal:Declare.KernelSilent id (cd,IsProof Lemma)) in exact_no_check (applist (lem,List.rev (Array.to_list (instance_from_named_context sign)))) gl @@ -3501,8 +3518,9 @@ let admit_as_an_axiom gl = let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in if occur_existential concl then error"\"admit\" cannot handle existentials."; let axiom = - let cd = Entries.ParameterEntry (concl,false) in - let con = Declare.declare_internal_constant na (cd,IsAssumption Logical) in + let cd = + Entries.ParameterEntry (Pfedit.get_used_variables(),concl,None) in + let con = Declare.declare_constant ~internal:Declare.KernelSilent na (cd,IsAssumption Logical) in constr_of_global (ConstRef con) in exact_no_check @@ -3517,7 +3535,6 @@ let unify ?(state=full_transparent_state) x y gl = modulo_delta = state; modulo_conv_on_closed_terms = Some state} in - let evd = w_unify false (pf_env gl) Reduction.CONV - ~flags x y (Evd.create_evar_defs (project gl)) + let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y in tclEVARS evd gl with _ -> tclFAIL 0 (str"Not unifiable") gl diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 5ceade1f..f8f32b79 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string val head_constr : constr -> constr * constr list @@ -42,7 +39,7 @@ val is_quantified_hypothesis : identifier -> goal sigma -> bool exception Bound -(*s Primitive tactics. *) +(** {6 Primitive tactics. } *) val introduction : identifier -> tactic val refine : constr -> tactic @@ -55,7 +52,7 @@ val fix : identifier option -> int -> tactic val mutual_cofix : identifier -> (identifier * constr) list -> int -> tactic val cofix : identifier option -> tactic -(*s Introduction tactics. *) +(** {6 Introduction tactics. } *) val fresh_id_in_env : identifier list -> identifier -> env -> identifier val fresh_id : identifier list -> identifier -> goal sigma -> identifier @@ -65,20 +62,21 @@ val intro : tactic val introf : tactic val intro_move : identifier option -> identifier move_location -> tactic - (* [intro_avoiding idl] acts as intro but prevents the new identifier + (** [intro_avoiding idl] acts as intro but prevents the new identifier to belong to [idl] *) val intro_avoiding : identifier list -> tactic val intro_replacing : identifier -> tactic val intro_using : identifier -> tactic val intro_mustbe_force : identifier -> tactic +val intro_then : (identifier -> tactic) -> tactic val intros_using : identifier list -> tactic val intro_erasing : identifier -> tactic val intros_replacing : identifier list -> tactic val intros : tactic -(* [depth_of_quantified_hypothesis b h g] returns the index of [h] in +(** [depth_of_quantified_hypothesis b h g] returns the index of [h] in the conclusion of goal [g], up to head-reduction if [b] is [true] *) val depth_of_quantified_hypothesis : bool -> quantified_hypothesis -> goal sigma -> int @@ -88,7 +86,7 @@ val intros_until : quantified_hypothesis -> tactic val intros_clearing : bool list -> tactic -(* Assuming a tactic [tac] depending on an hypothesis identifier, +(** Assuming a tactic [tac] depending on an hypothesis identifier, [try_intros_until tac arg] first assumes that arg denotes a quantified hypothesis (denoted by name or by index) and try to introduce it in context before to apply [tac], otherwise assume the @@ -97,21 +95,21 @@ val intros_clearing : bool list -> tactic val try_intros_until : (identifier -> tactic) -> quantified_hypothesis -> tactic -(* Apply a tactic on a quantified hypothesis, an hypothesis in context +(** Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) val onInductionArg : (constr with_bindings -> tactic) -> constr with_bindings induction_arg -> tactic -(*s Introduction tactics with eliminations. *) +(** {6 Introduction tactics with eliminations. } *) val intro_pattern : identifier move_location -> intro_pattern_expr -> tactic val intro_patterns : intro_pattern_expr located list -> tactic val intros_pattern : identifier move_location -> intro_pattern_expr located list -> tactic -(*s Exact tactics. *) +(** {6 Exact tactics. } *) val assumption : tactic val exact_no_check : constr -> tactic @@ -119,7 +117,7 @@ val vm_cast_no_check : constr -> tactic val exact_check : constr -> tactic val exact_proof : Topconstr.constr_expr -> tactic -(*s Reduction tactics. *) +(** {6 Reduction tactics. } *) type tactic_reduction = env -> evar_map -> constr -> constr @@ -156,7 +154,7 @@ val pattern_option : val reduce : red_expr -> clause -> tactic val unfold_constr : global_reference -> tactic -(*s Modification of the local context. *) +(** {6 Modification of the local context. } *) val clear : identifier list -> tactic val clear_body : identifier list -> tactic @@ -169,7 +167,7 @@ val rename_hyp : (identifier * identifier) list -> tactic val revert : identifier list -> tactic -(*s Resolution tactics. *) +(** {6 Resolution tactics. } *) val apply_type : constr -> constr list -> tactic val apply_term : constr -> constr list -> tactic @@ -193,7 +191,7 @@ val apply_in : val simple_apply_in : identifier -> constr -> tactic -(*s Elimination tactics. *) +(** {6 Elimination tactics. } *) (* @@ -219,52 +217,52 @@ val simple_apply_in : identifier -> constr -> tactic Principles taken from functional induction have the final (f...). *) -(* [rel_contexts] and [rel_declaration] actually contain triples, and +(** [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; - index: int; (* index of the elimination type in the scheme *) - params: rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) - nparams: int; (* number of parameters *) - predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) - npredicates: int; (* Number of predicates *) - branches: rel_context; (* branchr,...,branch1 *) - nbranches: int; (* Number of branches *) - args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *) - nargs: int; (* number of arguments *) - indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) + index: int; (** index of the elimination type in the scheme *) + params: rel_context; (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) + nparams: int; (** number of parameters *) + predicates: rel_context; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) + npredicates: int; (** Number of predicates *) + branches: rel_context; (** branchr,...,branch1 *) + nbranches: int; (** Number of branches *) + args: rel_context; (** (xni, Ti_ni) ... (x1, Ti_1) *) + nargs: int; (** number of arguments *) + indarg: rel_declaration option; (** Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) - concl: types; (* Qi x1...xni HI (f...), HI and (f...) + concl: types; (** Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) - indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) - farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) + indarg_in_concl: bool; (** true if HI appears at the end of conclusion *) + farg_in_concl: bool; (** true if (f...) appears at the end of conclusion *) } val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme val rebuild_elimtype_from_scheme: elim_scheme -> types -(* elim principle with the index of its inductive arg *) +(** elim principle with the index of its inductive arg *) type eliminator = { - elimindex : int option; (* None = find it automatically *) + elimindex : int option; (** None = find it automatically *) elimbody : constr with_bindings } -val elimination_clause_scheme : evars_flag -> - bool -> int -> clausenv -> clausenv -> tactic +val elimination_clause_scheme : evars_flag -> ?flags:unify_flags -> + int -> clausenv -> clausenv -> tactic -val elimination_in_clause_scheme : evars_flag -> identifier -> int -> - clausenv -> clausenv -> tactic +val elimination_in_clause_scheme : evars_flag -> ?flags:unify_flags -> + identifier -> int -> clausenv -> clausenv -> tactic val general_elim_clause_gen : (int -> Clenv.clausenv -> 'a -> tactic) -> 'a -> eliminator -> tactic val general_elim : evars_flag -> - constr with_bindings -> eliminator -> ?allow_K:bool -> tactic -val general_elim_in : evars_flag -> - identifier -> constr with_bindings -> eliminator -> tactic + constr with_bindings -> eliminator -> tactic +val general_elim_in : evars_flag -> identifier -> + constr with_bindings -> eliminator -> tactic val default_elim : evars_flag -> constr with_bindings -> tactic val simplest_elim : constr -> tactic @@ -273,37 +271,39 @@ val elim : val simple_induct : quantified_hypothesis -> tactic -val new_induct : evars_flag -> constr with_bindings induction_arg list -> +val new_induct : evars_flag -> + (evar_map * constr with_bindings) induction_arg list -> constr with_bindings option -> intro_pattern_expr located option * intro_pattern_expr located option -> clause option -> tactic -(*s Case analysis tactics. *) +(** {6 Case analysis tactics. } *) val general_case_analysis : evars_flag -> constr with_bindings -> tactic val simplest_case : constr -> tactic val simple_destruct : quantified_hypothesis -> tactic -val new_destruct : evars_flag -> constr with_bindings induction_arg list -> +val new_destruct : evars_flag -> + (evar_map * constr with_bindings) induction_arg list -> constr with_bindings option -> intro_pattern_expr located option * intro_pattern_expr located option -> clause option -> tactic -(*s Generic case analysis / induction tactics. *) +(** {6 Generic case analysis / induction tactics. } *) val induction_destruct : rec_flag -> evars_flag -> - (constr with_bindings induction_arg list * + ((evar_map * constr with_bindings) induction_arg list * constr with_bindings option * (intro_pattern_expr located option * intro_pattern_expr located option)) list * clause option -> tactic -(*s Eliminations giving the type instead of the proof. *) +(** {6 Eliminations giving the type instead of the proof. } *) val case_type : constr -> tactic val elim_type : constr -> tactic -(*s Some eliminations which are frequently used. *) +(** {6 Some eliminations which are frequently used. } *) val impE : identifier -> tactic val andE : identifier -> tactic @@ -313,7 +313,7 @@ val dAnd : clause -> tactic val dorE : bool -> clause ->tactic -(*s Introduction tactics. *) +(** {6 Introduction tactics. } *) val constructor_tac : evars_flag -> int option -> int -> constr bindings -> tactic @@ -332,7 +332,7 @@ val simplest_left : tactic val simplest_right : tactic val simplest_split : tactic -(*s Logical connective tactics. *) +(** {6 Logical connective tactics. } *) val register_setoid_reflexivity : tactic -> unit val reflexivity_red : bool -> tactic @@ -362,13 +362,15 @@ val assert_as : bool -> intro_pattern_expr located option -> constr -> tactic val forward : tactic option -> intro_pattern_expr located option -> constr -> tactic val letin_tac : (bool * intro_pattern_expr located) option -> name -> constr -> types option -> clause -> tactic +val letin_pat_tac : (bool * intro_pattern_expr located) option -> name -> + evar_map * constr -> types option -> clause -> tactic val assert_tac : name -> types -> tactic val assert_by : name -> types -> tactic -> tactic val pose_proof : name -> constr -> tactic val generalize : constr list -> tactic val generalize_gen : ((occurrences * constr) * name) list -> tactic -val generalize_dep : ?with_let:bool (* Don't lose let bindings *) -> constr -> tactic +val generalize_dep : ?with_let:bool (** Don't lose let bindings *) -> constr -> tactic val unify : ?state:Names.transparent_state -> constr -> constr -> tactic val resolve_classes : tactic @@ -382,3 +384,6 @@ val specialize_eqs : identifier -> tactic val register_general_multi_rewrite : (bool -> evars_flag -> constr with_bindings -> clause -> tactic) -> unit + +val register_subst_one : + (bool -> identifier -> identifier * constr * bool -> tactic) -> unit diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index b885b152..333d6a3a 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -19,6 +19,4 @@ Leminv Tacinterp Evar_tactics Autorewrite -Decl_interp -Decl_proof_instr Tactic_option diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index a17aba76..b7a58be4 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* !iff_unfolding); @@ -154,10 +153,12 @@ let flatten_contravariant_disj ist = let hyp = valueIn (VConstr ([],hyp)) in iter_tac (list_map_i (fun i arg -> let typ = valueIn (VConstr ([],mkArrow arg c)) in + let i = Tacexpr.Integer i in <:tactic< let typ := $typ in let hyp := $hyp in - assert typ by (intro; apply hyp; constructor $i; assumption) + let i := $i in + assert typ by (intro; apply hyp; constructor i; assumption) >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >> else <:tactic> @@ -268,8 +269,6 @@ let t_reduction_not = tacticIn reduction_not let intuition_gen tac = interp (tacticIn (tauto_intuit t_reduction_not tac)) -let simplif_gen = interp (tacticIn simplif) - let tauto_intuitionistic g = try intuition_gen <:tactic> g with @@ -301,5 +300,5 @@ END TACTIC EXTEND intuition | [ "intuition" ] -> [ intuition_gen default_intuition_tac ] -| [ "intuition" tactic(t) ] -> [ intuition_gen (fst t) ] +| [ "intuition" tactic(t) ] -> [ intuition_gen t ] END diff --git a/tactics/termdn.ml b/tactics/termdn.ml index 17329b6f..443acc6f 100644 --- a/tactics/termdn.ml +++ b/tactics/termdn.ml @@ -1,19 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* t - (* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *) + (** [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *) val add : t -> transparent_state -> (constr_pattern * Z.t) -> t val rmv : t -> transparent_state -> (constr_pattern * Z.t) -> t - (* [lookup t c] looks for patterns (with their action) matching term [c] *) + (** [lookup t c] looks for patterns (with their action) matching term [c] *) val lookup : t -> transparent_state -> constr -> (constr_pattern * Z.t) list val app : ((constr_pattern * Z.t) -> unit) -> t -> unit - (*i*) - (* These are for Nbtermdn *) + (**/**) + (** These are for Nbtermdn *) type term_label = | GRLabel of global_reference @@ -68,5 +64,5 @@ sig val constr_pat_discr : constr_pattern -> (term_label * constr_pattern list) option val constr_val_discr : constr -> (term_label * constr list) lookup_res -(*i*) + (**/**) end -- cgit v1.2.3