From 7cfc4e5146be5666419451bdd516f1f3f264d24a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 25 Jan 2015 14:42:51 +0100 Subject: Imported Upstream version 8.5~beta1+dfsg --- tactics/auto.ml | 1412 +++---------- tactics/auto.mli | 225 +-- tactics/autorewrite.ml | 159 +- tactics/autorewrite.mli | 20 +- tactics/btermdn.ml | 254 +-- tactics/btermdn.mli | 21 +- tactics/class_tactics.ml | 847 ++++++++ tactics/class_tactics.ml4 | 833 -------- tactics/class_tactics.mli | 32 + tactics/contradiction.ml | 145 +- tactics/contradiction.mli | 11 +- tactics/coretactics.ml4 | 229 +++ tactics/dn.ml | 102 +- tactics/dn.mli | 41 +- tactics/dnet.ml | 291 +++ tactics/dnet.mli | 124 ++ tactics/eauto.ml4 | 272 ++- tactics/eauto.mli | 21 +- tactics/elim.ml | 149 +- tactics/elim.mli | 27 +- tactics/elimschemes.ml | 78 +- tactics/elimschemes.mli | 2 +- tactics/eqdecide.ml | 212 ++ tactics/eqdecide.ml4 | 188 -- tactics/eqdecide.mli | 17 + tactics/eqschemes.ml | 297 +-- tactics/eqschemes.mli | 20 +- tactics/equality.ml | 1380 +++++++------ tactics/equality.mli | 116 +- tactics/evar_tactics.ml | 74 +- tactics/evar_tactics.mli | 13 +- tactics/extraargs.ml4 | 202 +- tactics/extraargs.mli | 58 +- tactics/extratactics.ml4 | 730 ++++--- tactics/extratactics.mli | 12 +- tactics/ftactic.ml | 86 + tactics/ftactic.mli | 67 + tactics/g_class.ml4 | 84 + tactics/g_eqdecide.ml4 | 27 + tactics/g_rewrite.ml4 | 263 +++ tactics/geninterp.ml | 38 + tactics/geninterp.mli | 28 + tactics/hiddentac.ml | 142 -- tactics/hiddentac.mli | 124 -- tactics/hightactics.mllib | 5 +- tactics/hints.ml | 1221 ++++++++++++ tactics/hints.mli | 227 +++ tactics/hipattern.ml4 | 262 +-- tactics/hipattern.mli | 29 +- tactics/inv.ml | 479 +++-- tactics/inv.mli | 35 +- tactics/leminv.ml | 104 +- tactics/leminv.mli | 25 +- tactics/nbtermdn.ml | 146 -- tactics/nbtermdn.mli | 47 - tactics/refine.ml | 397 ---- tactics/refine.mli | 11 - tactics/rewrite.ml | 2099 ++++++++++++++++++++ tactics/rewrite.ml4 | 2121 -------------------- tactics/rewrite.mli | 117 ++ tactics/taccoerce.ml | 269 +++ tactics/taccoerce.mli | 95 + tactics/tacenv.ml | 128 ++ tactics/tacenv.mli | 55 + tactics/tacintern.ml | 867 ++++++++ tactics/tacintern.mli | 66 + tactics/tacinterp.ml | 4620 ++++++++++++++++++------------------------- tactics/tacinterp.mli | 168 +- tactics/tacsubst.ml | 360 ++++ tactics/tacsubst.mli | 30 + tactics/tactic_matching.ml | 373 ++++ tactics/tactic_matching.mli | 49 + tactics/tactic_option.ml | 32 +- tactics/tactic_option.mli | 5 +- tactics/tacticals.ml | 671 +++++-- tactics/tacticals.mli | 264 ++- tactics/tactics.ml | 4543 +++++++++++++++++++++++++----------------- tactics/tactics.mli | 439 ++-- tactics/tactics.mllib | 15 +- tactics/tauto.ml4 | 356 ++-- tactics/term_dnet.ml | 388 ++++ tactics/term_dnet.mli | 88 + tactics/termdn.ml | 135 -- tactics/termdn.mli | 68 - 84 files changed, 17638 insertions(+), 13244 deletions(-) create mode 100644 tactics/class_tactics.ml delete mode 100644 tactics/class_tactics.ml4 create mode 100644 tactics/class_tactics.mli create mode 100644 tactics/coretactics.ml4 create mode 100644 tactics/dnet.ml create mode 100644 tactics/dnet.mli create mode 100644 tactics/eqdecide.ml delete mode 100644 tactics/eqdecide.ml4 create mode 100644 tactics/eqdecide.mli create mode 100644 tactics/ftactic.ml create mode 100644 tactics/ftactic.mli create mode 100644 tactics/g_class.ml4 create mode 100644 tactics/g_eqdecide.ml4 create mode 100644 tactics/g_rewrite.ml4 create mode 100644 tactics/geninterp.ml create mode 100644 tactics/geninterp.mli delete mode 100644 tactics/hiddentac.ml delete mode 100644 tactics/hiddentac.mli create mode 100644 tactics/hints.ml create mode 100644 tactics/hints.mli delete mode 100644 tactics/nbtermdn.ml delete mode 100644 tactics/nbtermdn.mli delete mode 100644 tactics/refine.ml delete mode 100644 tactics/refine.mli create mode 100644 tactics/rewrite.ml delete mode 100644 tactics/rewrite.ml4 create mode 100644 tactics/rewrite.mli create mode 100644 tactics/taccoerce.ml create mode 100644 tactics/taccoerce.mli create mode 100644 tactics/tacenv.ml create mode 100644 tactics/tacenv.mli create mode 100644 tactics/tacintern.ml create mode 100644 tactics/tacintern.mli create mode 100644 tactics/tacsubst.ml create mode 100644 tactics/tacsubst.mli create mode 100644 tactics/tactic_matching.ml create mode 100644 tactics/tactic_matching.mli create mode 100644 tactics/term_dnet.ml create mode 100644 tactics/term_dnet.mli delete mode 100644 tactics/termdn.ml delete mode 100644 tactics/termdn.mli (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 3451957e..45052685 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -1,1011 +1,29 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [v] - | h::tl -> if pri_order v h then v::h::tl else h::(insrec tl) - in - insrec l - -(* Nov 98 -- Papageno *) -(* Les Hints sont ré-organisés en plusieurs databases. - - La table impérative "searchtable", de type "hint_db_table", - associe une database (hint_db) à chaque nom. - - Une hint_db est une table d'association fonctionelle constr -> search_entry - 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 ont un pattern - - un discrimination net borné (Btermdn.t) constitué de tous les - patterns de la seconde liste de tactiques *) - -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 = 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) = - if x.pri = y.pri && x.pat = y.pat then - match x.code,y.code with - | Res_pf(cstr,_),Res_pf(cstr1,_) -> - eq_constr cstr cstr1 - | ERes_pf(cstr,_),ERes_pf(cstr1,_) -> - eq_constr cstr cstr1 - | Give_exact cstr,Give_exact cstr1 -> - eq_constr cstr cstr1 - | Res_pf_THEN_trivial_fail(cstr,_) - ,Res_pf_THEN_trivial_fail(cstr1,_) -> - eq_constr cstr cstr1 - | _,_ -> false - else - false - -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) - -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' = List.stable_sort pri_order_int l' in - Sort.merge pri_order l sl' - -module Constr_map = Map.Make(RefOrdered) - -let is_transparent_gr (ids, csts) = function - | VarRef id -> Idpred.mem id ids - | 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 subst_path_atom subst p = - match p with - | PathAny -> p - | PathHints grs -> - let gr' gr = fst (subst_global subst gr) in - let grs' = list_smartmap gr' grs in - if grs' == grs then p else PathHints grs' - -let rec subst_hints_path subst hp = - match hp with - | PathAtom p -> - let p' = subst_path_atom subst p in - if p' == p then hp else PathAtom p' - | 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 - or with no associated pattern. *) - 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 = [] } - - let find key db = - try Constr_map.find key db.hintdb_map - with Not_found -> empty_se - - let map_none db = - 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 - 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 - List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) l') - - let is_exact = function - | Give_exact _ -> true - | _ -> false - - 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 && - 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,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 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,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat - - let add_one kv db = - let (k,v) = translate_hint kv in - let st',db,rebuild = - match v.code with - | Unfold_nth egr -> - let addunf (ids,csts) (ids',csts') = - match egr with - | EvalVarRef id -> (Idpred.add id ids, csts), (Idset.add id ids', csts') - | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts') - in - let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in - state, { db with hintdb_unfolds = unfs }, true - | _ -> db.hintdb_state, db, false - in - let db = if db.use_dn && rebuild then rebuild_db st' db else db - in addkv k (next_hint_id db) v db - - let add_list l db = List.fold_left (fun db k -> add_one k db) db l - - 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 (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 - - let set_transparent_state db st = - 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 - -end - -module Hintdbmap = Gmap - -type hint_db = Hint_db.t - -type frozen_hint_db_table = (string,hint_db) Hintdbmap.t - -type hint_db_table = (string,hint_db) Hintdbmap.t ref - -type hint_db_name = string - -let searchtable = (ref Hintdbmap.empty : hint_db_table) - -let searchtable_map name = - Hintdbmap.find name !searchtable -let searchtable_add (name,db) = - searchtable := Hintdbmap.add name db !searchtable -let current_db_names () = - Hintdbmap.dom !searchtable - -(**************************************************************************) -(* Definition of the summary *) -(**************************************************************************) - -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 -let unfreeze fs = searchtable := fs - -let _ = Summary.declare_summary "search" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init } - - -(**************************************************************************) -(* Auxiliary functions to prepare AUTOHINT objects *) -(**************************************************************************) - -let rec nb_hyp c = match kind_of_term c with - | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2 - | _ -> 0 - -(* adding and removing tactics in the search table *) - -let try_head_pattern c = - try head_pattern_bound c - with BoundPattern -> error "Bound head variable." - -let name_of_constr c = try Some (global_of_constr c) with Not_found -> None - -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 hd = - try head_pattern_bound pat - with BoundPattern -> failwith "make_exact_entry" - in - (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 ?(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 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; - 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; - name = name; - code = ERes_pf(c,cty) }) - end - | _ -> failwith "make_apply_entry" - -(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose - c is a constr - cty is the type of constr *) - -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 ?name; make_apply_entry env sigma flags pri ?name] - in - if ents = [] then - errorlabstrm "Hint" - (pr_lconstr c ++ spc() ++ - (if pi1 flags then str"cannot be used as a hint." - else str "can be used as a hint only for eauto.")); - ents - -(* 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 - ~name:(PathHints [VarRef hname]) - (mkVar hname, htyp)] - with - | Failure _ -> [] - | e when Logic.catchable_exception e -> anomaly "make_resolve_hyp" - -(* REM : in most cases hintname = id *) -let make_unfold 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; - pat = pat; - name = PathAny; - code = Extern tacast }) - -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))); - name = name; - code=Res_pf_THEN_trivial_fail(c,t) }) - -open Vernacexpr - -(**************************************************************************) -(* declaration of the AUTOHINT library object *) -(**************************************************************************) - -(* If the database does not exist, it is created *) -(* TODO: should a warning be printed in this case ?? *) - -let get_db dbname = - try searchtable_map dbname - with Not_found -> Hint_db.empty empty_transparent_state false - -let add_hint dbname hintlist = - let db = get_db dbname in - let db' = Hint_db.add_list hintlist db in - searchtable_add (dbname,db') - -let add_transparency dbname grs b = - let db = get_db dbname in - let st = Hint_db.transparent_state db in - let st' = - List.fold_left (fun (ids, csts) gr -> - match gr with - | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts) - | EvalVarRef v -> (if b then Idpred.add else Idpred.remove) v ids, csts) - st grs - in searchtable_add (dbname, Hint_db.set_transparent_state db st') - -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 - | 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 subst_key gr = - let (lab'', elab') = subst_global subst gr in - let gr' = - (try head_of_constr_reference (fst (head_constr_bound elab')) - with Tactics.Bound -> lab'') - in if gr' == gr then gr else gr' - in - let subst_hint (k,data as hint) = - let k' = Option.smartmap subst_key k in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - let code' = match data.code with - | Res_pf (c,t) -> - 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 - 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 - if ref==ref' then data.code else Unfold_nth ref' - | Extern tac -> - let tac' = !forward_subst_tactic subst tac in - if tac==tac' then data.code else Extern tac' - in - let name' = subst_path_atom subst data.name in - let data' = - if data.pat==pat' && data.name == name' && data.code==code' then data - else { data with pat = pat'; name = name'; 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)) - | AddHints hintlist -> - let hintlist' = list_smartmap subst_hint hintlist in - if hintlist' == hintlist then obj else - (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 = (AddHints []) then Dispose else Substitute obj - -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; } - -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 *) -(**************************************************************************) -let add_resolves env sigma clist local dbnames = - List.iter - (fun dbname -> - Lib.add_anonymous_leaf - (inAutoHint - (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, 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 = - List.iter - (fun dbname -> Lib.add_anonymous_leaf - (inAutoHint (local,dbname, AddTransparency (l, b)))) - dbnames - -let add_extern pri pat tacast local dbname = - (* We check that all metas that appear in tacast have at least - one occurence in the left pattern pat *) - let tacmetas = [] in - match pat with - | Some (patmetas,pat) -> - (match (list_subtract tacmetas patmetas) with - | i::_ -> - errorlabstrm "add_extern" - (str "The meta-variable ?" ++ Ppconstr.pr_patvar i ++ str" is not bound.") - | [] -> - Lib.add_anonymous_leaf - (inAutoHint(local,dbname, AddHints [make_extern pri (Some pat) tacast]))) - | None -> - Lib.add_anonymous_leaf - (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 - -let add_trivials env sigma l local dbnames = - List.iter - (fun dbname -> - Lib.add_anonymous_leaf ( - inAutoHint(local,dbname, - AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l)))) - dbnames - -let forward_intern_tac = - ref (fun _ -> failwith "intern_tac is not installed for auto") - -let set_extern_intern_tac f = forward_intern_tac := f - -type hints_entry = - | 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 - int * (patvar list * constr_pattern) option * 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 e when Errors.noncritical e -> PathAny) - | _ -> PathAny - -let interp_hints h = - let f c = - let evd,c = Constrintern.interp_open_constr Evd.empty (Global.env()) c in - let c = prepare_hint (Global.env()) (evd,c) in - Evarutil.check_evars (Global.env()) Evd.empty evd c; - c in - 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 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 - Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind"; - 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) -> - let pat = Option.map fp patcom in - let tacexp = !forward_intern_tac (match pat with None -> [] | Some (l, _) -> l) tacexp in - HintsExternEntry (pri, pat, tacexp) - -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 - | HintsExternEntry (pri, pat, tacexp) -> - add_externs pri pat tacexp local dbnames - -(**************************************************************************) -(* Functions for printing the hints *) -(**************************************************************************) - -let pr_autotactic = - function - | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c) - | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c) - | Give_exact c -> (str"exact " ++ pr_constr c) - | Res_pf_THEN_trivial_fail (c,clenv) -> - (str"apply " ++ pr_constr c ++ str" ; trivial") - | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) - | Extern tac -> - let env = - try - let (_, env) = Pfedit.get_current_goal_context () in - env - with e when Errors.noncritical e -> Global.env () - in - (str "(*external*) " ++ Pptactic.pr_glob_tactic env tac) - -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 ()) - -let pr_hints_db (name,db,hintlist) = - (str "In the database " ++ str name ++ str ":" ++ - if hintlist = [] then (str " nothing" ++ fnl ()) - else (fnl () ++ pr_hint_list hintlist)) - -(* Print all hints associated to head c in any database *) -let pr_hint_list_for_head c = - let dbs = Hintdbmap.to_list !searchtable in - let valid_dbs = - map_succeed - (fun (name,db) -> (name,db, List.map (fun v -> 0, v) (Hint_db.map_all c db))) - dbs - in - if valid_dbs = [] then - (str "No hint declared for :" ++ pr_global c) - else - hov 0 - (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ - hov 0 (prlist pr_hints_db valid_dbs)) - -let pr_hint_ref ref = pr_hint_list_for_head ref - -(* Print all hints associated to head id in any database *) -let print_hint_ref ref = ppnl(pr_hint_ref ref) - -let pr_hint_term cl = - try - let dbs = Hintdbmap.to_list !searchtable in - let valid_dbs = - let fn = try - let (hdc,args) = head_constr_bound cl in - let hd = head_of_constr_reference hdc in - if occur_existential cl then - Hint_db.map_all hd - else Hint_db.map_auto (hd, applist (hdc,args)) - 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 - (str "No hint applicable for current goal") - else - (str "Applicable Hints :" ++ fnl () ++ - hov 0 (prlist pr_hints_db valid_dbs)) - with Match_failure _ | Failure _ -> - (str "No hint applicable for current goal") - -let error_no_such_hint_database x = - error ("No such Hint database: "^x^".") - -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 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 = - let (ids, csts) = Hint_db.transparent_state db in - msgnl (hov 0 - ((if Hint_db.use_dn db then str"Discriminated database" - 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 (List.map (fun x -> (0,x)) hintlist))) - | None -> - msg (hov 0 - (str "For any goal -> " ++ - pr_hint_list (List.map (fun x -> (0, x)) hintlist)))) - db - -let print_hint_db_by_name dbname = - try - let db = searchtable_map dbname in print_hint_db db - with Not_found -> - error_no_such_hint_database dbname - -(* displays all the hints of all databases *) -let print_searchtable () = - Hintdbmap.iter - (fun name db -> - msg (str "In the database " ++ str name ++ str ":" ++ fnl ()); - print_hint_db db) - !searchtable +open Locus +open Proofview.Notations +open Hints (**************************************************************************) (* Automatic tactics *) @@ -1015,79 +33,82 @@ 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) -> Int.equal hint.pri 0) l (* tell auto not to reuse already instantiated metas in unification (for compatibility, since otherwise, apply succeeds oftener) *) open Unification -let auto_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly_in_conv_on_closed_terms = false; - modulo_delta = empty_transparent_state; +let auto_core_unif_flags_of st1 st2 useeager = { + modulo_conv_on_closed_terms = Some st1; + use_metas_eagerly_in_conv_on_closed_terms = useeager; + use_evars_eagerly_in_conv_on_closed_terms = false; + modulo_delta = st2; modulo_delta_types = full_transparent_state; - modulo_delta_in_merge = None; check_applied_meta_types = false; - resolve_evars = true; use_pattern_unification = false; use_meta_bound_pattern_unification = true; - frozen_evars = ExistentialSet.empty; + frozen_evars = Evar.Set.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 *) +let auto_unif_flags_of st1 st2 useeager = + let flags = auto_core_unif_flags_of st1 st2 useeager in { + core_unify_flags = flags; + merge_unify_flags = flags; + subterm_unify_flags = { flags with modulo_delta = empty_transparent_state }; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = true +} -let h_clenv_refine ev c clenv = - Refiner.abstract_tactic (TacApply (true,ev,[c,NoBindings],None)) - (Clenvtac.clenv_refine ev clenv) +let auto_unif_flags = + auto_unif_flags_of full_transparent_state empty_transparent_state false -let unify_resolve_nodelta (c,clenv) gl = - let clenv' = connect_clenv gl clenv in - let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in - h_clenv_refine false c clenv'' gl +let auto_flags_of_state st = + auto_unif_flags_of full_transparent_state st false -let unify_resolve flags (c,clenv) gl = - let clenv' = connect_clenv gl clenv in - let clenv'' = clenv_unique_resolver ~flags clenv' gl in - h_clenv_refine false c clenv'' gl +(* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve_gen = function - | None -> unify_resolve_nodelta - | Some flags -> unify_resolve flags +let unify_resolve_nodelta poly (c,clenv) = + Proofview.Goal.nf_enter begin fun gl -> + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = Tacmach.New.of_old connect_clenv gl clenv' in + let clenv'' = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags:auto_unif_flags clenv' gl) gl in + Clenvtac.clenv_refine false clenv'' + end + +let unify_resolve poly flags (c,clenv) = + Proofview.Goal.nf_enter begin fun gl -> + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = Tacmach.New.of_old connect_clenv gl clenv' in + let clenv'' = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv' gl) gl in + Clenvtac.clenv_refine false clenv'' + end + +let unify_resolve_gen poly = function + | None -> unify_resolve_nodelta poly + | Some flags -> unify_resolve poly flags + +let exact poly (c,clenv) = + let ctx, c' = + if poly then + let evd', subst = Evd.refresh_undefined_universes clenv.evd in + let ctx = Evd.evar_universe_context evd' in + ctx, subst_univs_level_constr subst c + else + let ctx = Evd.evar_universe_context clenv.evd in + ctx, c + in + Proofview.Goal.enter begin fun gl -> + let sigma = Evd.merge_universe_context (Proofview.Goal.sigma gl) ctx in + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (exact_check c') + end (* Util *) -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) - | _ -> - [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 (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 ?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 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 terme pour l'affichage ? (HH) *) @@ -1100,19 +121,23 @@ si après Intros la conclusion matche le pattern. (* 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") - -let set_extern_interp f = forward_interp_tactic := f +let (forward_interp_tactic, extern_interp) = Hook.make () -let conclPattern concl pat tac gl = - let constr_bindings = +let conclPattern concl pat tac = + let constr_bindings env sigma = match pat with - | None -> [] + | None -> Proofview.tclUNIT Id.Map.empty | Some pat -> - try matches pat concl - with PatternMatchingFailure -> error "conclPattern" in - !forward_interp_tactic constr_bindings tac gl + try + Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) + with Constr_matching.PatternMatchingFailure -> + Proofview.tclZERO (UserError ("conclPattern",str"conclPattern")) + in + Proofview.Goal.enter (fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + constr_bindings env sigma >>= fun constr_bindings -> + Hook.get forward_interp_tactic constr_bindings tac) (***********************************************************) (** A debugging / verbosity framework for trivial and auto *) @@ -1147,8 +172,8 @@ let no_dbg () = (Off,0,ref []) let mk_trivial_dbg debug = let d = - if debug = Debug || !global_debug_trivial then Debug - else if debug = Info || !global_info_trivial then Info + if debug == Debug || !global_debug_trivial then Debug + else if debug == Info || !global_info_trivial then Info else Off in (d,0,ref []) @@ -1157,8 +182,8 @@ let mk_trivial_dbg debug = let mk_auto_dbg debug = let d = - if debug = Debug || !global_debug_auto then Debug - else if debug = Info || !global_info_auto then Info + if debug == Debug || !global_debug_auto then Debug + else if debug == Info || !global_info_auto then Info else Off in (d,1,ref []) @@ -1172,25 +197,27 @@ let tclLOG (dbg,depth,trace) pp tac = | Debug -> (* For "debug (trivial/auto)", we directly output messages *) let s = String.make depth '*' in - begin fun gl -> + Proofview.V82.tactic begin fun gl -> try - let out = tac gl in + let out = Proofview.V82.of_tactic tac gl in msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); out with reraise -> + let reraise = Errors.push reraise in msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); - raise reraise + iraise reraise end | Info -> (* For "info (trivial/auto)", we store a log trace *) - begin fun gl -> + Proofview.V82.tactic begin fun gl -> try - let out = tac gl in + let out = Proofview.V82.of_tactic tac gl in trace := (depth, Some pp) :: !trace; out with reraise -> + let reraise = Errors.push reraise in trace := (depth, None) :: !trace; - raise reraise + iraise reraise end (** For info, from the linear trace information, we reconstitute the part @@ -1207,37 +234,39 @@ let rec cleanup_info_trace depth acc = function and erase_subtree depth = function | [] -> [] - | (d,_) :: l -> if d = depth then l else erase_subtree depth l + | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l let pr_info_atom (d,pp) = - msg_debug (str (String.make d ' ') ++ pp () ++ str ".") + str (String.make d ' ') ++ pp () ++ str "." let pr_info_trace = function | (Info,_,{contents=(d,Some pp)::l}) -> - List.iter pr_info_atom (cleanup_info_trace d [(d,pp)] l) - | _ -> () + prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l) + | _ -> mt () let pr_info_nop = function - | (Info,_,_) -> msg_debug (str "idtac.") - | _ -> () + | (Info,_,_) -> str "idtac." + | _ -> mt () let pr_dbg_header = function - | (Off,_,_) -> () - | (Debug,0,_) -> msg_debug (str "(* debug trivial : *)") - | (Debug,_,_) -> msg_debug (str "(* debug auto : *)") - | (Info,0,_) -> msg_debug (str "(* info trivial : *)") - | (Info,_,_) -> msg_debug (str "(* info auto : *)") + | (Off,_,_) -> mt () + | (Debug,0,_) -> str "(* debug trivial : *)" + | (Debug,_,_) -> str "(* debug auto : *)" + | (Info,0,_) -> str "(* info trivial : *)" + | (Info,_,_) -> str "(* info auto : *)" let tclTRY_dbg d tac = - tclORELSE0 - (fun gl -> - pr_dbg_header d; - let out = tac gl in - pr_info_trace d; - out) - (fun gl -> - pr_info_nop d; - tclIDTAC gl) + let (level, _, _) = d in + let delay f = Proofview.tclUNIT () >>= fun () -> f () in + let tac = match level with + | Off -> tac + | Debug | Info -> delay (fun () -> msg_debug (pr_dbg_header d ++ fnl () ++ pr_info_trace d); tac) + in + let after = match level with + | Info -> delay (fun () -> msg_debug (pr_info_nop d); Proofview.tclUNIT ()) + | Off | Debug -> Proofview.tclUNIT () + in + Tacticals.New.tclORELSE0 tac after (**************************************************************************) (* The Trivial tactic *) @@ -1247,16 +276,21 @@ let tclTRY_dbg d tac = (* 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 auto_unif_flags = + auto_unif_flags_of full_transparent_state empty_transparent_state false + let flags_of_state st = - {auto_unif_flags with - modulo_conv_on_closed_terms = Some st; modulo_delta = st} + auto_unif_flags_of st st false + +let auto_flags_of_state st = + auto_unif_flags_of full_transparent_state st false let hintmap_of hdc concl = match hdc with | None -> Hint_db.map_none | Some hdc -> - if occur_existential concl then Hint_db.map_all hdc - else Hint_db.map_auto (hdc,concl) + if occur_existential concl then Hint_db.map_existential hdc concl + else Hint_db.map_auto hdc concl let exists_evaluable_reference env = function | EvalConstRef _ -> true @@ -1265,41 +299,49 @@ let exists_evaluable_reference env = function let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption -let rec trivial_fail_db dbg mod_delta db_list local_db gl = +let rec trivial_fail_db dbg mod_delta db_list local_db = let intro_tac = - tclTHEN (dbg_intro dbg) - (fun g'-> - let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db) g') + Tacticals.New.tclTHEN (dbg_intro dbg) + ( Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let nf c = Evarutil.nf_evar sigma c in + let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in + let hyp = Context.map_named_declaration nf decl in + let hintl = make_resolve_hyp env sigma hyp + in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db) + end) in - tclFIRST - ((dbg_assumption dbg)::intro_tac:: - (List.map tclCOMPLETE - (trivial_resolve dbg mod_delta db_list local_db (pf_concl gl)))) gl + Proofview.Goal.enter begin fun gl -> + let concl = Tacmach.New.pf_nf_concl gl in + Tacticals.New.tclFIRST + ((dbg_assumption dbg)::intro_tac:: + (List.map Tacticals.New.tclCOMPLETE + (trivial_resolve dbg mod_delta db_list local_db concl))) + end and my_find_search_nodelta db_list local_db hdc concl = List.map (fun hint -> (None,hint)) - (list_map_append (hintmap_of hdc concl) (local_db::db_list)) + (List.map_append (hintmap_of hdc concl) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_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_in_conv_on_closed_terms = true} in let f = hintmap_of hdc concl in if occur_existential concl then - list_map_append + List.map_append (fun db -> if Hint_db.use_dn db then let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags,x)) (f db) else - let flags = {flags with modulo_delta = Hint_db.transparent_state db} in + let flags = auto_flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags,x)) (f db)) (local_db::db_list) else - list_map_append (fun db -> + List.map_append (fun db -> if Hint_db.use_dn db then let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags, x)) (f db) @@ -1309,39 +351,40 @@ and my_find_search_delta db_list local_db hdc concl = let l = match hdc with None -> Hint_db.map_none db | Some hdc -> - if (Idpred.is_empty ids && Cpred.is_empty csts) - then Hint_db.map_auto (hdc,concl) db - else Hint_db.map_all hdc db - in {flags with modulo_delta = st}, l + if (Id.Pred.is_empty ids && Cpred.is_empty csts) + then Hint_db.map_auto hdc concl db + else Hint_db.map_existential hdc concl db + in auto_flags_of_state st, l in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) -and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) = +and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) = let tactic = match t with - | Res_pf (c,cl) -> unify_resolve_gen flags (c,cl) - | ERes_pf _ -> (fun gl -> error "eres_pf") - | Give_exact c -> exact_check c + | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl) + | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf") + | Give_exact (c, cl) -> exact poly (c, cl) | Res_pf_THEN_trivial_fail (c,cl) -> - tclTHEN - (unify_resolve_gen flags (c,cl)) + Tacticals.New.tclTHEN + (unify_resolve_gen poly flags (c,cl)) (* With "(debug) trivial", we shouldn't end here, and with "debug auto" we don't display the details of inner trivial *) - (trivial_fail_db (no_dbg ()) (flags <> None) db_list local_db) + (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db) | Unfold_nth c -> - (fun gl -> + Proofview.V82.tactic (fun gl -> if exists_evaluable_reference (pf_env gl) c then - tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl + tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) gl else tclFAIL 0 (str"Unbound reference") gl) - | Extern tacast -> conclPattern concl p tacast + | Extern tacast -> + conclPattern concl p tacast in tclLOG dbg (fun () -> pr_autotactic t) tactic and trivial_resolve dbg mod_delta db_list local_db cl = try let head = - try let hdconstr,_ = head_constr_bound cl in - Some (head_of_constr_reference hdconstr) + try let hdconstr = decompose_app_bound cl in + Some hdconstr with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) @@ -1352,36 +395,33 @@ and trivial_resolve dbg mod_delta db_list local_db cl = (** 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 ?(debug=Off) lems dbnames gl = +let trivial ?(debug=Off) lems dbnames = + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let db_list = make_db_list dbnames in let d = mk_trivial_dbg debug in + let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d - (trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl - -let full_trivial ?(debug=Off) lems gl = - let dbnames = Hintdbmap.dom !searchtable in - let dbnames = list_remove "v62" dbnames in - let db_list = List.map (fun x -> searchtable_map x) dbnames in + (trivial_fail_db d false db_list hints) + end + +let full_trivial ?(debug=Off) lems = + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let db_list = current_pure_db () in let d = mk_trivial_dbg debug in + let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d - (trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl + (trivial_fail_db d false db_list hints) + end let gen_trivial ?(debug=Off) lems = function | None -> full_trivial ~debug lems | Some l -> trivial ~debug lems l -let h_trivial ?(debug=Off) lems l = - Refiner.abstract_tactic (TacTrivial (debug,List.map snd lems,l)) - (gen_trivial ~debug lems l) +let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l (**************************************************************************) (* The classical Auto tactic *) @@ -1390,88 +430,90 @@ let h_trivial ?(debug=Off) lems l = let possible_resolve dbg mod_delta db_list local_db cl = try let head = - try let hdconstr,_ = head_constr_bound cl in - Some (head_of_constr_reference hdconstr) + try let hdconstr = decompose_app_bound cl in + Some hdconstr with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) (my_find_search mod_delta db_list local_db head cl) with Not_found -> [] -let dbg_case dbg id = - tclLOG dbg (fun () -> str "case " ++ pr_id id) (simplest_case (mkVar id)) - -let decomp_unary_term_then dbg (id,_,typc) kont1 kont2 gl = - try - let ccl = applist (head_constr typc) in - match Hipattern.match_with_conjunction ccl with - | Some (_,args) -> - tclTHEN (dbg_case dbg id) (kont1 (List.length args)) gl - | None -> - kont2 gl - with UserError _ -> kont2 gl - -let decomp_empty_term dbg (id,_,typc) gl = - if Hipattern.is_empty_type typc then - dbg_case dbg id gl - else - errorlabstrm "Auto.decomp_empty_term" (str "Not an empty type.") - -let extend_local_db gl decl db = - Hint_db.add_list (make_resolve_hyp (pf_env gl) (project gl) decl) db +let extend_local_db decl db gl = + Hint_db.add_list (make_resolve_hyp (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) decl) db (* Introduce an hypothesis, then call the continuation tactic [kont] with the hint db extended with the so-obtained hypothesis *) let intro_register dbg kont db = - tclTHEN (dbg_intro dbg) - (onLastDecl (fun decl gl -> kont (extend_local_db gl decl db) gl)) + Tacticals.New.tclTHEN (dbg_intro dbg) + (Proofview.Goal.enter begin fun gl -> + let extend_local_db decl db = extend_local_db decl db gl in + Tacticals.New.onLastDecl (fun decl -> kont (extend_local_db decl db)) + end) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) -exception Uplift of tactic list - let search d n mod_delta db_list local_db = let rec search d n local_db = - if n=0 then (fun gl -> error "BOUND 2") else - tclORELSE0 (dbg_assumption d) - (tclORELSE0 (intro_register d (search d n) local_db) - (fun gl -> - let d' = incr_dbg d in - tclFIRST - (List.map - (fun ntac -> tclTHEN ntac (search d' (n-1) local_db)) - (possible_resolve d mod_delta db_list local_db (pf_concl gl))) gl)) + (* spiwack: the test of [n] to 0 must be done independently in + each goal. Hence the [tclEXTEND] *) + Proofview.tclEXTEND [] begin + if Int.equal n 0 then Proofview.tclZERO (Errors.UserError ("",str"BOUND 2")) else + Tacticals.New.tclORELSE0 (dbg_assumption d) + (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) + ( Proofview.Goal.enter begin fun gl -> + let concl = Tacmach.New.pf_nf_concl gl in + let d' = incr_dbg d in + Tacticals.New.tclFIRST + (List.map + (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) + (possible_resolve d mod_delta db_list local_db concl)) + end)) + end [] in search d n local_db let default_search_depth = ref 5 -let delta_auto ?(debug=Off) mod_delta n lems dbnames gl = +let delta_auto debug mod_delta n lems dbnames = + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let db_list = make_db_list dbnames in let d = mk_auto_dbg debug in + let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d - (search d n mod_delta db_list (make_local_hint_db false lems gl)) gl + (search d n mod_delta db_list hints) + end -let auto ?(debug=Off) n = delta_auto ~debug false n +let delta_auto = + if Flags.profile then + let key = Profile.declare_profile "delta_auto" in + Profile.profile5 key delta_auto + else delta_auto -let new_auto ?(debug=Off) n = delta_auto ~debug true n +let auto ?(debug=Off) n = delta_auto debug false n + +let new_auto ?(debug=Off) n = delta_auto debug true n let default_auto = auto !default_search_depth [] [] -let delta_full_auto ?(debug=Off) mod_delta n lems gl = - let dbnames = Hintdbmap.dom !searchtable in - let dbnames = list_remove "v62" dbnames in - let db_list = List.map (fun x -> searchtable_map x) dbnames in +let delta_full_auto ?(debug=Off) mod_delta n lems = + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let db_list = current_pure_db () in let d = mk_auto_dbg debug in + let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d - (search d n mod_delta db_list (make_local_hint_db false lems gl)) gl + (search d n mod_delta db_list hints) + end let full_auto ?(debug=Off) n = delta_full_auto ~debug false n let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n -let default_full_auto gl = full_auto !default_search_depth [] gl +let default_full_auto = full_auto !default_search_depth [] let gen_auto ?(debug=Off) n lems dbnames = let n = match n with None -> !default_search_depth | Some n -> n in @@ -1479,8 +521,4 @@ let gen_auto ?(debug=Off) n lems dbnames = | None -> full_auto ~debug n lems | Some l -> auto ~debug n lems l -let inj_or_var = Option.map (fun n -> ArgArg n) - -let h_auto ?(debug=Off) n lems l = - Refiner.abstract_tactic (TacAuto (debug,inj_or_var n,List.map snd lems,l)) - (gen_auto ~debug n lems l) +let h_auto ?(debug=Off) n lems l = gen_auto ~debug n lems l diff --git a/tactics/auto.mli b/tactics/auto.mli index 5ac2de87..ea3f0ac0 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -1,268 +1,87 @@ (************************************************************************) (* 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 - type t - val empty : transparent_state -> bool -> t - val find : global_reference -> t -> search_entry - val map_none : t -> pri_auto_tactic list - val map_all : global_reference -> t -> pri_auto_tactic list - 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 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 - -type hint_db_name = string - -type hint_db = Hint_db.t - -type hints_entry = - | 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 - int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr - -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]. - [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 extern_interp : + (patvar_map -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic) Hook.t -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 - -val print_hint_ref : global_reference -> unit - -val print_hint_db_by_name : hint_db_name -> unit - -val print_hint_db : Hint_db.t -> unit - -(** [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 -> ?name:hints_path_atom -> constr * constr -> hint_entry - -(** [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; - [c] is the term given as an exact proof to solve the goal; - [cty] is the type of [c]. *) - -val make_apply_entry : - env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> - constr * constr -> hint_entry - -(** 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 -> ?name:hints_path_atom -> - constr -> hint_entry list - -(** [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. *) - -val make_resolve_hyp : - env -> evar_map -> named_declaration -> hint_entry list - -(** [make_extern pri pattern tactic_expr] *) - -val make_extern : - int -> constr_pattern option -> Tacexpr.glob_tactic_expr - -> hint_entry - -val set_extern_interp : - (patvar_map -> Tacexpr.glob_tactic_expr -> tactic) -> unit - -val set_extern_intern_tac : - (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) - -> unit - -val set_extern_subst_tactic : - (substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr) - -> unit - -(** 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 : ?ts:transparent_state -> bool -> open_constr list -> goal sigma -> hint_db +(** Auto and related automation tactics *) val priority : ('a * pri_auto_tactic) list -> ('a * pri_auto_tactic) list val default_search_depth : int ref -val auto_unif_flags : Unification.unify_flags +val auto_flags_of_state : transparent_state -> Unification.unify_flags (** Try unification with the precompiled clause, then use registered Apply *) -val unify_resolve_nodelta : (constr * clausenv) -> tactic +val unify_resolve_nodelta : polymorphic -> (constr * clausenv) -> unit Proofview.tactic -val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic +val unify_resolve : polymorphic -> Unification.unify_flags -> (constr * clausenv) -> unit Proofview.tactic (** [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 +val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic (** The Auto tactic *) (** The use of the "core" database can be de-activated by passing "nocore" amongst the databases. *) -val make_db_list : hint_db_name list -> hint_db list - val auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> hint_db_name list -> tactic + int -> open_constr list -> hint_db_name list -> unit Proofview.tactic (** Auto with more delta. *) val new_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> hint_db_name list -> tactic + int -> open_constr list -> hint_db_name list -> unit Proofview.tactic (** auto with default search depth and with the hint database "core" *) -val default_auto : tactic +val default_auto : unit Proofview.tactic (** auto with all hint databases except the "v62" compatibility database *) val full_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> tactic + int -> open_constr list -> unit Proofview.tactic (** auto with all hint databases except the "v62" compatibility database and doing delta *) val new_full_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> tactic + int -> open_constr list -> unit Proofview.tactic (** auto with default search depth and with all hint databases except the "v62" compatibility database *) -val default_full_auto : tactic +val default_full_auto : unit Proofview.tactic (** The generic form of auto (second arg [None] means all bases) *) val gen_auto : ?debug:Tacexpr.debug -> - int option -> open_constr list -> hint_db_name list option -> tactic + int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic (** The hidden version of auto *) val h_auto : ?debug:Tacexpr.debug -> - int option -> open_constr list -> hint_db_name list option -> tactic + int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic (** Trivial *) val trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list -> tactic + open_constr list -> hint_db_name list -> unit Proofview.tactic val gen_trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list option -> tactic + open_constr list -> hint_db_name list option -> unit Proofview.tactic val full_trivial : ?debug:Tacexpr.debug -> - open_constr list -> tactic + open_constr list -> unit Proofview.tactic val h_trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list option -> tactic - -val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds - -(** Hook for changing the initialization of auto *) - -val add_auto_init : (unit -> unit) -> unit + open_constr list -> hint_db_name list option -> unit Proofview.tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 93441a93..ee8e1855 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -1,39 +1,37 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - errorlabstrm "AutoRewrite" - (str ("Rewriting base "^(bas)^" does not exist.")) + try raw_find_base bas + with Not_found -> + errorlabstrm "AutoRewrite" + (str ("Rewriting base "^(bas)^" does not exist.")) let find_rewrites bas = List.rev_map snd (HintDN.find_all (find_base bas)) @@ -86,45 +74,55 @@ let find_rewrites bas = let find_matches bas pat = let base = find_base bas in let res = HintDN.search_pattern base pat in - List.map (fun ((_,rew), esubst, subst) -> rew) res + List.map snd res let print_rewrite_hintdb bas = - ppnl (str "Database " ++ str bas ++ (Pp.cut ()) ++ - prlist_with_sep Pp.cut + (str "Database " ++ str bas ++ fnl () ++ + prlist_with_sep fnl (fun h -> str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ - str " then use tactic " ++ - Pptactic.pr_glob_tactic (Global.env()) h.rew_tac) + Option.cata (fun tac -> str " then use tactic " ++ + Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) -type raw_rew_rule = loc * constr * bool * raw_tactic_expr +type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in - let lrul = List.map (fun h -> (h.rew_lemma,h.rew_l2r,Tacinterp.eval_tactic h.rew_tac)) lrul in - tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) -> - tclTHEN tac - (tclREPEAT_MAIN - (tclTHENFIRST (general_rewrite_maybe_in dir csr tc) tac_main))) - tclIDTAC lrul)) + let try_rewrite dir ctx c tc = Proofview.Goal.nf_enter (fun gl -> + let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c in + let sigma = Proofview.Goal.sigma gl in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (general_rewrite_maybe_in dir c' tc) + ) in + let lrul = List.map (fun h -> + let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in + (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> + Tacticals.New.tclTHEN tac + (Tacticals.New.tclREPEAT_MAIN + (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) + (Proofview.tclUNIT()) lrul)) (* The AutoRewrite tactic *) let autorewrite ?(conds=Naive) tac_main lbas = - tclREPEAT_MAIN (tclPROGRESS + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac bas -> - tclTHEN tac + Tacticals.New.tclTHEN tac (one_base (fun dir c tac -> - let tac = tac, conds in - general_rewrite dir all_occurrences true false ~tac c) + let tac = (tac, conds) in + general_rewrite dir AllOccurrences true false ~tac c) tac_main bas)) - tclIDTAC lbas)) + (Proofview.tclUNIT()) lbas)) -let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic = - fun gl -> +let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = + Proofview.Goal.nf_enter begin fun gl -> (* let's check at once if id exists (to raise the appropriate error) *) - let _ = List.map (Tacmach.pf_get_hyp gl) idl in + let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in let general_rewrite_in id = let id = ref id in let to_be_cleared = ref false in @@ -133,15 +131,15 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic = 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) ^".") + raise (Logic.RefinerError (Logic.NoSuchHyp !id)) in - let gl' = general_rewrite_in dir all_occurrences true ~tac:(tac, conds) false !id cstr false gl in + let gl' = Proofview.V82.of_tactic (general_rewrite_in dir AllOccurrences 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 (Goal.V82.hyps gl'.Evd.sigma g) with (lastid,_,_)::_ -> - if last_hyp_id <> lastid then + if not (Id.equal last_hyp_id lastid) then begin let gl'' = if !to_be_cleared then @@ -159,11 +157,13 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic = | _ -> assert false) (* there must be at least an hypothesis *) | _ -> assert false (* rewriting cannot complete a proof *) in - tclMAP (fun id -> - tclREPEAT_MAIN (tclPROGRESS + let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y z w) in + Tacticals.New.tclMAP (fun id -> + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac bas -> - tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) tclIDTAC lbas))) - idl gl + Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) + idl + end let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] @@ -171,53 +171,48 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = let try_do_hyps treat_id l = autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas in - if cl.concl_occs <> all_occurrences_expr & - cl.concl_occs <> no_occurrences_expr + if cl.concl_occs != AllOccurrences && + cl.concl_occs != NoOccurrences then - error "The \"at\" syntax isn't available yet for the autorewrite tactic." + Proofview.tclZERO (UserError("" , str"The \"at\" syntax isn't available yet for the autorewrite tactic.")) else let compose_tac t1 t2 = match cl.onhyps with | Some [] -> t1 - | _ -> tclTHENFIRST t1 t2 + | _ -> Tacticals.New.tclTHENFIRST t1 t2 in compose_tac - (if cl.concl_occs <> no_occurrences_expr then autorewrite ~conds tac_main lbas else tclIDTAC) + (if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ()) (match cl.onhyps with | Some l -> try_do_hyps (fun ((_,id),_) -> id) l | None -> - fun gl -> (* try to rewrite in all hypothesis (except maybe the rewritten one) *) - let ids = Tacmach.pf_ids_of_hyps gl - in try_do_hyps (fun id -> id) ids gl) + Proofview.Goal.nf_enter begin fun gl -> + let ids = Tacmach.New.pf_ids_of_hyps gl in + try_do_hyps (fun id -> id) ids + end) -let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds Refiner.tclIDTAC +let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds (Proofview.tclUNIT()) -let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl gl = - let onconcl = cl.Tacexpr.concl_occs <> no_occurrences_expr in - match onconcl,cl.Tacexpr.onhyps with +let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = + let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in + match onconcl,cl.Locus.onhyps with | false,Some [_] | true,Some [] | false,Some [] -> (* autorewrite with .... in clause using tac n'est sur que si clause represente soit le but soit UNE hypothese *) - gen_auto_multi_rewrite conds tac_main lbas cl gl + gen_auto_multi_rewrite conds tac_main lbas cl | _ -> - Util.errorlabstrm "autorewrite" - (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") + Proofview.tclZERO (UserError ("autorewrite",strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.")) (* Functions necessary to the library object declaration *) let cache_hintrewrite (_,(rbase,lrl)) = - let base = - try find_base rbase - with e when Errors.noncritical e -> HintDN.empty - in - let max = - try fst (Util.list_last (HintDN.find_all base)) - with e when Errors.noncritical e -> 0 + let base = try raw_find_base rbase with Not_found -> HintDN.empty in + let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0 in let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in - rewtab:=Stringmap.add rbase (HintDN.union lrl base) !rewtab + rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab let subst_hintrewrite (subst,(rbase,list as node)) = @@ -250,12 +245,6 @@ type hypinfo = { hyp_right : constr; } -let evd_convertible env evd x y = - try - 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 e when Errors.noncritical e -> false - let decompose_applied_relation metas env sigma c ctype left2right = let find_rel ty = let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in @@ -296,7 +285,7 @@ let find_applied_relation metas loc env sigma c left2right = | Some c -> c | None -> user_err_loc (loc, "decompose_applied_relation", - str"The type" ++ spc () ++ Printer.pr_constr_env env ctype ++ + str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) @@ -304,12 +293,12 @@ let add_rew_rules base lrul = let counter = ref 0 in let lrul = List.fold_left - (fun dn (loc,c,b,t) -> + (fun dn (loc,(c,ctx),b,t) -> let info = find_applied_relation false loc (Global.env ()) Evd.empty c b in let pat = if b then info.hyp_left else info.hyp_right in let rul = { rew_lemma = c; rew_type = info.hyp_ty; - rew_pat = pat; rew_l2r = b; - rew_tac = Tacinterp.glob_tactic t} + rew_pat = pat; rew_ctx = ctx; rew_l2r = b; + rew_tac = Option.map Tacintern.glob_tactic t} in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index b0016449..9905b520 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_rew_rule list -> unit @@ -21,25 +20,26 @@ val add_rew_rules : string -> raw_rew_rule list -> unit 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 +val autorewrite : ?conds:conditions -> unit Proofview.tactic -> string list -> unit Proofview.tactic +val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> string list -> unit Proofview.tactic (** Rewriting rules *) type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; + rew_ctx: Univ.universe_context_set; rew_l2r: bool; - rew_tac: glob_tactic_expr } + rew_tac: glob_tactic_expr option } val find_rewrites : string -> rew_rule list val find_matches : string -> constr -> rew_rule list -val auto_multi_rewrite : ?conds:conditions -> string list -> Tacticals.clause -> tactic +val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> unit Proofview.tactic -val auto_multi_rewrite_with : ?conds:conditions -> tactic -> string list -> Tacticals.clause -> tactic +val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic -val print_rewrite_hintdb : string -> unit +val print_rewrite_hintdb : string -> Pp.std_ppcmds open Clenv @@ -56,6 +56,6 @@ type hypinfo = { } val find_applied_relation : bool -> - Util.loc -> + Loc.t -> Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 182cac7d..1f5177c3 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -1,16 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* RefOrdered.compare gr1 gr2 +| _ -> Pervasives.compare t1 t2 (** OK *) + +type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything + +let decomp_pat = + let rec decrec acc = function + | PApp (f,args) -> decrec (Array.to_list args @ acc) f + | PProj (p, c) -> (PRef (ConstRef (Projection.constant p)), c :: acc) + | c -> (c,acc) + in + decrec [] + +let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Proj (p, c) -> (mkConst (Projection.constant p), c :: acc) + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] + +let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) + | Var id -> Label(GRLabel (VarRef id),l) + | Const _ -> Everything + | _ -> Nothing + +let constr_pat_discr t = + if not (Patternops.occur_meta_pattern t) then + None + else + match decomp_pat t with + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) + | _ -> None + +let constr_val_discr_st (idpred,cpred) t = + let c, l = decomp t in + match kind_of_term c with + | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) + | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) + | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) + | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) + | Prod (n, d, c) -> Label(ProdLabel, [d; c]) + | Lambda (n, d, c) -> + if List.is_empty l then + Label(LambdaLabel, [d; c] @ l) + else Everything + | Sort _ -> Label(SortLabel, []) + | Evar _ -> Everything + | _ -> Nothing + +let constr_pat_discr_st (idpred,cpred) t = + match decomp_pat t with + | PRef ((IndRef _) as ref), args + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) -> + Some(GRLabel ref,args) + | PVar v, args when not (Id.Pred.mem v idpred) -> + Some(GRLabel (VarRef v),args) + | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) -> + Some (GRLabel ref, args) + | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) + | PLambda (_, d, c), [] -> Some (LambdaLabel, [d ; c]) + | PSort s, [] -> Some (SortLabel, []) + | _ -> None + +let bounded_constr_pat_discr_st st (t,depth) = + if Int.equal depth 0 then + None + else + match constr_pat_discr_st st t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + +let bounded_constr_val_discr_st st (t,depth) = + if Int.equal depth 0 then + Nothing + else + match constr_val_discr_st st t with + | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) + | Nothing -> Nothing + | Everything -> Everything + +let bounded_constr_pat_discr (t,depth) = + if Int.equal depth 0 then + None + else + match constr_pat_discr t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + +let bounded_constr_val_discr (t,depth) = + if Int.equal depth 0 then + Nothing + else + match constr_val_discr t with + | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) + | Nothing -> Nothing + | Everything -> Everything module Make = functor (Z : Map.OrderedType) -> struct - module Term_dn = Termdn.Make(Z) - - module X = struct - type t = constr_pattern*int - let compare = Pervasives.compare - end - - module Y = struct - type t = Term_dn.term_label - let compare x y = - let make_name n = - match n with - | Term_dn.GRLabel(ConstRef con) -> - Term_dn.GRLabel(ConstRef(constant_of_kn(canonical_con con))) - | Term_dn.GRLabel(IndRef (kn,i)) -> - Term_dn.GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) - | Term_dn.GRLabel(ConstructRef ((kn,i),j ))-> - Term_dn.GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) - | k -> k - in - Pervasives.compare (make_name x) (make_name y) + + module Y = struct + type t = term_label + let compare = compare_term_label end - - module Dn = Dn.Make(X)(Y)(Z) - + + module Dn = Dn.Make(Y)(Z) + type t = Dn.t let create = Dn.create - let decomp = - let rec decrec acc c = match kind_of_term c with - | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f - | Cast (c1,_,_) -> decrec acc c1 - | _ -> (c,acc) - in - decrec [] - - let constr_val_discr t = - let c, l = decomp t in - match kind_of_term c with - | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) - | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) - | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) - | Const _ -> Dn.Everything - | _ -> Dn.Nothing - - let constr_val_discr_st (idpred,cpred) t = - let c, l = decomp t in - match kind_of_term c with - | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l) - | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) - | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) - | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) - | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c]) - | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l) - | Sort _ -> Dn.Label(Term_dn.SortLabel, []) - | Evar _ -> Dn.Everything - | _ -> Dn.Nothing - - let bounded_constr_pat_discr_st st (t,depth) = - if depth = 0 then - None - else - match Term_dn.constr_pat_discr_st st t with - | None -> None - | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) - - let bounded_constr_val_discr_st st (t,depth) = - if depth = 0 then - Dn.Nothing - else - match constr_val_discr_st st t with - | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) - | Dn.Nothing -> Dn.Nothing - | Dn.Everything -> Dn.Everything - - let bounded_constr_pat_discr (t,depth) = - if depth = 0 then - None - else - match Term_dn.constr_pat_discr t with - | None -> None - | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) - - let bounded_constr_val_discr (t,depth) = - if depth = 0 then - Dn.Nothing - else - match constr_val_discr t with - | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) - | Dn.Nothing -> Dn.Nothing - | Dn.Everything -> Dn.Everything - - let add = function - | None -> - (fun dn (c,v) -> + | None -> + (fun dn (c,v) -> Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> + | Some st -> + (fun dn (c,v) -> Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) - + let rmv = function - | None -> - (fun dn (c,v) -> + | None -> + (fun dn (c,v) -> Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> + | Some st -> + (fun dn (c,v) -> Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) - + let lookup = function - | None -> + | None -> (fun dn t -> - List.map - (fun ((c,_),v) -> (c,v)) - (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth))) - | Some st -> + Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth)) + | Some st -> (fun dn t -> - List.map - (fun ((c,_),v) -> (c,v)) - (Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth))) - - let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn - + Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth)) + + let app f dn = Dn.app f dn + end - + diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index f9c2271a..6c396b4c 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* sig @@ -21,9 +33,8 @@ sig val add : transparent_state option -> t -> (constr_pattern * Z.t) -> t val rmv : transparent_state option -> t -> (constr_pattern * Z.t) -> t - val lookup : transparent_state option -> t -> constr -> (constr_pattern * Z.t) list - val app : ((constr_pattern * Z.t) -> unit) -> t -> unit + val lookup : transparent_state option -> t -> constr -> Z.t list + val app : (Z.t -> unit) -> t -> unit end - -val dnet_depth : int ref +val dnet_depth : int ref diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml new file mode 100644 index 00000000..1c15fa40 --- /dev/null +++ b/tactics/class_tactics.ml @@ -0,0 +1,847 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + if Evar.Map.mem ev !tosee then + visit ev (Evar.Map.find ev !tosee)) evs; + tosee := Evar.Map.remove ev !tosee; + l' := ev :: !l'; + in + while not (Evar.Map.is_empty !tosee) do + let ev, evi = Evar.Map.min_binding !tosee in + visit ev evi + done; + List.rev !l' + +let evars_to_goals p evm = + let goals = ref Evar.Map.empty in + let map ev evi = + let evi, goal = p evm ev evi in + let () = if goal then goals := Evar.Map.add ev evi !goals in + evi + in + let evm = Evd.raw_map_undefined map evm in + if Evar.Map.is_empty !goals then None + else Some (!goals, evm) + +(** Typeclasses instance search tactic / eauto *) + +open Auto + +open Unification + +let auto_core_unif_flags st freeze = { + modulo_conv_on_closed_terms = Some st; + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + modulo_delta = st; + modulo_delta_types = st; + check_applied_meta_types = false; + use_pattern_unification = true; + use_meta_bound_pattern_unification = true; + frozen_evars = freeze; + restrict_conv_on_strict_subterms = false; (* ? *) + modulo_betaiota = true; + modulo_eta = !typeclasses_modulo_eta; +} + +let auto_unif_flags freeze st = + let fl = auto_core_unif_flags st freeze in + { core_unify_flags = fl; + merge_unify_flags = fl; + subterm_unify_flags = fl; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = false +} + +let rec eq_constr_mod_evars x y = + match kind_of_term x, kind_of_term y with + | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true + | _, _ -> compare_constr eq_constr_mod_evars x y + +let progress_evars t = + Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let check = + Proofview.Goal.nf_enter begin fun gl' -> + let newconcl = Proofview.Goal.concl gl' in + if eq_constr_mod_evars concl newconcl + then Tacticals.New.tclFAIL 0 (str"No progress made (modulo evars)") + else Proofview.tclUNIT () + end + in t <*> check + end + + +let e_give_exact flags poly (c,clenv) gl = + let c, gl = + if poly then + let clenv', subst = Clenv.refresh_undefined_univs clenv in + let clenv' = connect_clenv gl clenv' in + let c = Vars.subst_univs_level_constr subst c in + c, {gl with sigma = clenv'.evd} + else c, gl + in + let t1 = pf_type_of gl c in + tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl + +let unify_e_resolve poly flags (c,clenv) gls = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gls clenv' in + let clenv' = clenv_unique_resolver ~flags clenv' gls in + Proofview.V82.of_tactic (Clenvtac.clenv_refine true ~with_classes:false clenv') gls + +let unify_resolve poly flags (c,clenv) gls = + let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in + let clenv' = connect_clenv gls clenv' in + let clenv' = clenv_unique_resolver ~flags clenv' gls in + Proofview.V82.of_tactic + (Clenvtac.clenv_refine false ~with_classes:false clenv') gls + +let clenv_of_prods poly nprods (c, clenv) gls = + if poly || Int.equal nprods 0 then Some clenv + else + let ty = pf_type_of gls c in + let diff = nb_prod ty - nprods in + if Pervasives.(>=) diff 0 then + (* Was Some clenv... *) + Some (mk_clenv_from_n gls (Some diff) (c,ty)) + else None + +let with_prods nprods poly (c, clenv) f gls = + match clenv_of_prods poly nprods (c, clenv) gls with + | None -> tclFAIL 0 (str"Not enough premisses") gls + | Some clenv' -> f (c, clenv') gls + +(** Hack to properly solve dependent evars that are typeclasses *) + +let rec e_trivial_fail_db db_list local_db goal = + let tacl = + Eauto.registered_e_assumption :: + (tclTHEN (Proofview.V82.of_tactic Tactics.intro) + (function g'-> + let d = pf_last_hyp g' in + 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 (project goal) (pf_concl goal))) + in + tclFIRST (List.map tclCOMPLETE tacl) goal + +and e_my_find_search db_list local_db hdc complete sigma concl = + let prods, concl = decompose_prod_assum concl in + let nprods = List.length prods in + let freeze = + try + let cl = Typeclasses.class_info (fst hdc) in + if cl.cl_strict then + Evd.evars_of_term concl + else Evar.Set.empty + with _ -> Evar.Set.empty + in + let hintl = + List.map_append + (fun db -> + let tacs = + if Hint_db.use_dn db then (* Using dnet *) + Hint_db.map_eauto hdc concl db + else Hint_db.map_existential hdc concl db + in + let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in + List.map (fun x -> (flags, x)) tacs) + (local_db::db_list) + in + let tac_of_hint = + fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> + let tac = + match t with + | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags) + | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags) + | Give_exact c -> e_give_exact flags poly c + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN (with_prods nprods poly (term,cl) (unify_e_resolve poly flags)) + (if complete then tclIDTAC else e_trivial_fail_db db_list local_db) + | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c]) + | Extern tacast -> + Proofview.V82.of_tactic (conclPattern concl p tacast) + in + let tac = if complete then tclCOMPLETE tac else tac in + match t with + | 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 sigma concl = + try + e_my_find_search db_list local_db + (decompose_app_bound concl) true sigma concl + with Bound | Not_found -> [] + +let e_possible_resolve db_list local_db sigma concl = + try + e_my_find_search db_list local_db + (decompose_app_bound concl) false sigma concl + with Bound | Not_found -> [] + +let catchable = function + | Refiner.FailError _ -> true + | e -> Logic.catchable_exception e + +let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) + +let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) + +type autoinfo = { hints : hint_db; is_evar: existential_key option; + only_classes: bool; unique : 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 + +type atac = auto_result tac + +(* Some utility types to avoid the need of -rectypes *) + +type 'a optionk = + | Nonek + | Somek of 'a * 'a optionk fk + +type ('a,'b) optionk2 = + | Nonek2 + | Somek2 of 'a * 'b * ('a,'b) optionk2 fk + +let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = + let cty = Evarutil.nf_evar sigma cty in + let rec iscl env ty = + let ctx, ar = decompose_prod_assum ty in + match kind_of_term (fst (decompose_app ar)) with + | Const (c,_) -> is_class (ConstRef c) + | Ind (i,_) -> is_class (IndRef i) + | _ -> + let env' = Environ.push_rel_context ctx env in + let ty' = whd_betadeltaiota env' ar in + if not (Term.eq_constr ty' ar) then iscl env' ty' + else false + in + 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 (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) + (true,false,Flags.is_verbose()) pri false + (IsConstr (c,Univ.ContextSet.empty))) + hints) + else [] + in + (hints @ List.map_filter + (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) + with Failure _ | UserError _ -> None) + [make_exact_entry ~name env sigma pri false; + make_apply_entry ~name env sigma flags pri false]) + else [] + +let pf_filtered_hyps gls = + 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 -> + let consider = + try let (_, b, t) = Global.lookup_named (pi1 hyp) in + (* Section variable, reindex only if the type changed *) + not (Term.eq_constr t (pi3 hyp)) + with Not_found -> true + in + if consider then + let path, hint = + PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp + in + (PathOr (paths, path), hint @ hints) + else (paths, hints)) + (PathEmpty, []) sign + in Hint_db.add_list hintlist (Hint_db.empty st true) + +let make_autogoal_hints = + let cache = ref (true, Environ.empty_named_context_val, + Hint_db.empty full_transparent_state true) + in + fun only_classes ?(st=full_transparent_state) g -> + let sign = pf_filtered_hyps g in + let (onlyc, sign', cached_hints) = !cache in + if onlyc == only_classes && + (sign == sign' || Environ.eq_named_context_val sign sign') then + cached_hints + else + let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in + cache := (only_classes, sign, hints); hints + +let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = + { skft = fun sk fk {it = gl,hints; sigma=s;} -> + let res = try Some (tac {it=gl; sigma=s;}) + with e when catchable e -> None in + match res with + | Some gls -> sk (f gls hints) fk + | None -> fk () } + +let intro_tac : atac = + lift_tactic (Proofview.V82.of_tactic Tactics.intro) + (fun {it = gls; sigma = s} info -> + let gls' = + List.map (fun g' -> + 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 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 = + { 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 } + +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 is_Prop env sigma concl = + let ty = Retyping.get_type_of env sigma concl in + match kind_of_term ty with + | Sort (Prop Null) -> true + | _ -> false + +let is_unique env concl = + try + let (cl,u), args = dest_class_app env concl in + cl.cl_unique + with _ -> false + +let needs_backtrack env evd oev concl = + if Option.is_empty oev || is_Prop env evd concl then + occur_existential concl + else true + +let hints_tac hints = + { skft = fun sk fk {it = gl,info; sigma = s;} -> + let env = Goal.V82.env s gl in + let concl = Goal.V82.concl s gl in + let tacgl = {it = gl; sigma = s;} in + let poss = e_possible_resolve hints info.hints s concl in + let unique = is_unique env concl in + 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 + (match res with + | None -> aux i foundone tl + | Some {it = gls; sigma = s';} -> + if !typeclasses_debug then + msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp + ++ str" on" ++ spc () ++ pr_ev s gl); + let sgls = + evars_to_goals + (fun evm ev evi -> + if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) && + (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') -> + if not !typeclasses_dependency_order then + (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s') + else + (* Reorder with dependent subgoals. *) + let evm = List.fold_left + (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in + let gls = top_sort s' evm in + (List.map (fun ev -> Some ev, ev) gls, 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 + let fk' = + (fun () -> + let do_backtrack = + if unique then occur_existential concl + else if info.unique then true + else if List.is_empty gls' then + needs_backtrack env s' info.is_evar concl + else true + in + if !typeclasses_debug then + msg_debug + ((if do_backtrack then str"Backtracking after " + else str "Not backtracking after ") + ++ Lazy.force pp); + if do_backtrack then aux (succ i) true tl + else fk ()) + in + sk glsv fk') + | [] -> + if not foundone && !typeclasses_debug then + msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ + Printer.pr_constr_env (Goal.V82.env s gl) s concl ++ + spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); + fk () + in aux 1 false poss } + +let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = + let rec aux s (acc : autogoal list list) fk = function + | (gl,info) :: gls -> + (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 fk'' = + if not info.unique && List.is_empty gls' && + not (needs_backtrack (Goal.V82.env s gl) s + info.is_evar (Goal.V82.concl s gl)) + then fk + else fk' + in + aux s' (gls'::acc) fk'' gls) + fk {it = (gl,info); sigma = s; }) + | [] -> Somek2 (List.rev acc, s, fk) + in fun {it = gls; sigma = s; } fk -> + let rec aux' = function + | Nonek2 -> fk () + | Somek2 (res, s', fk') -> + let goals' = List.concat res in + sk {it = goals'; sigma = s'; } (fun () -> aux' (fk' ())) + in aux' (aux s [] (fun () -> Nonek2) gls) + +let then_tac (first : atac) (second : atac) : atac = + { skft = fun sk fk -> first.skft (then_list second sk) fk } + +let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = + t.skft (fun x _ -> Some x) (fun _ -> None) gl + +type run_list_res = auto_result optionk + +let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = + (then_list t (fun x fk -> Somek (x, fk))) + gl + (fun _ -> Nonek) + +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 rec fix_limit limit (t : 'a tac) : 'a tac = + if Int.equal 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) ?(unique=false) ?(st=full_transparent_state) cut ev g = + let hints = make_autogoal_hints only_classes ~st g in + (g.it, { hints = hints ; is_evar = ev; unique = unique; + only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none"); + auto_path = []; auto_cut = cut }) + + +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) ?(unique=false) + ?(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 ~unique + ~st cut (Some g) {it = g; sigma = evm'; } in + (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm'; } + +let get_result r = + match r with + | Nonek -> None + | Somek (gls, fk) -> Some (gls.sigma,fk) + +let run_on_evars ?(only_classes=true) ?(unique=false) ?(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 goals = + if !typeclasses_dependency_order then + top_sort evm' goals + else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals) + in + let res = run_list_tac tac p goals + (make_autogoals ~only_classes ~unique ~st hints goals evm') in + match get_result res with + | None -> raise Not_found + | Some (evm', fk) -> + Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) + +let eauto_tac hints = + 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; } -> + {it = List.map fst goals; sigma = s;} + +let real_eauto ?limit unique st hints p evd = + let res = + run_on_evars ~st ~unique p evd hints (eauto_tac ?limit hints) + in + match res with + | None -> evd + | Some (evd', fk) -> + if unique then + (match get_result (fk ()) with + | Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions" + | None -> evd') + else evd' + +let resolve_all_evars_once debug limit unique p evd = + let db = searchtable_map typeclasses_db in + real_eauto ?limit unique (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(Evar.Set)(Evar.Map) + +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 (Evar.Set.union evx evy) p) + cstrs + +let evar_dependencies evm p = + Evd.fold_undefined + (fun ev evi _ -> + let evars = Evar.Set.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 unique = + 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' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in + let evd = sig_sig gls' 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_instantiation_problem := + (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) + +(** [split_evars] returns groups of undefined evars according to dependencies *) + +let split_evars evm = + let p = Intpart.create () in + evar_dependencies evm p; + deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p; + Intpart.partition p + +let is_inference_forced p evd ev = + try + 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 + | Evar_kinds.ImplicitArg (_, _, b) -> b + | Evar_kinds.QuestionMark _ -> false + | _ -> true + else true + with Not_found -> assert false + +let is_mandatory p comp evd = + Evar.Set.exists (is_inference_forced p evd) comp + +(** In case of unsatisfiable constraints, build a nice error message *) + +let error_unresolvable env comp evd = + let evd = Evarutil.nf_evar_map_undefined evd in + let is_part ev = match comp with + | None -> true + | Some s -> Evar.Set.mem ev s + in + let fold ev evi (found, accu) = + let ev_class = class_of_constr evi.evar_concl in + if not (Option.is_empty ev_class) && is_part ev then + (* focus on one instance if only one was searched for *) + if not found then (true, Some ev) + else (found, None) + else (found, accu) + in + let (_, ev) = Evd.fold_undefined fold evd (true, None) in + Pretype_errors.unsatisfiable_constraints + (Evarutil.nf_env_evar evd env) evd ev comp + +(** 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 = + let check ev evi = snd (p oevd ev evi) in + Evar.Map.exists check (Evd.undefined_map evd) + +(** Revert the resolvability status of evars after resolution, + potentially unprotecting some evars that were set unresolvable + just for this call to resolution. *) + +let revert_resolvability oevd evd = + let map ev evi = + try + if not (Typeclasses.is_resolvable evi) then + let evi' = Evd.find_undefined oevd ev in + if Typeclasses.is_resolvable evi' then + Typeclasses.mark_resolvable evi + else evi + else evi + with Not_found -> evi + in + Evd.raw_map_undefined map evd + +(** 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 unique env p oevd do_split fail = + let split = if do_split then split_evars oevd else [Evar.Set.empty] in + let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true + in + let rec docomp evd = function + | [] -> revert_resolvability oevd evd + | comp :: comps -> + let p = select_and_update_evars p oevd (in_comp comp) in + try + let evd' = resolve_all_evars_once debug m unique 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. *) + let comp = if do_split then Some comp else None in + error_unresolvable env comp evd + else (* Best effort: do nothing on this component *) + docomp evd comps + in docomp oevd split + +let initial_select_evars filter = + fun evd ev evi -> + filter ev (snd evi.Evd.evar_source) && + Typeclasses.is_class_evar evd evi + +let resolve_typeclass_evars debug m unique env evd filter split fail = + let evd = + try Evarconv.consider_remaining_unif_problems + ~ts:(Typeclasses.classes_transparent_state ()) env evd + with e when Errors.noncritical e -> evd + in + resolve_all_evars debug m unique env (initial_select_evars filter) evd split fail + +let solve_inst debug depth env evd filter unique split fail = + resolve_typeclass_evars debug depth unique env evd filter split fail + +let _ = + Typeclasses.solve_instantiations_problem := + solve_inst false !typeclasses_depth + +let set_typeclasses_debug d = (:=) typeclasses_debug d; + Typeclasses.solve_instantiations_problem := solve_inst d !typeclasses_depth + +let get_typeclasses_debug () = !typeclasses_debug + +let set_typeclasses_depth d = (:=) typeclasses_depth d; + Typeclasses.solve_instantiations_problem := solve_inst !typeclasses_debug !typeclasses_depth + +let get_typeclasses_depth () = !typeclasses_depth + +open Goptions + +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 = + 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 typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl = + try + let dbs = List.map_filter + (fun db -> try Some (searchtable_map db) + with e when Errors.noncritical e -> None) + dbs + in + let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in + eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl + with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl + +(** Take the head of the arity of a constr. + Used in the partial application tactic. *) + +let rec head_of_constr t = + let t = strip_outer_cast(collapse_appl t) in + match kind_of_term t with + | Prod (_,_,c2) -> head_of_constr c2 + | LetIn (_,_,_,c2) -> head_of_constr c2 + | App (f,args) -> head_of_constr f + | _ -> t + +let head_of_constr h c = + let c = head_of_constr c in + letin_tac None (Name h) c None Locusops.allHyps + +let not_evar c = match kind_of_term c with +| Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar") +| _ -> Proofview.tclUNIT () + +let is_ground c gl = + if Evarutil.is_ground_term (project gl) c then tclIDTAC gl + else tclFAIL 0 (str"Not ground") gl + +let autoapply c i gl = + let flags = auto_unif_flags Evar.Set.empty + (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in + let cty = pf_type_of gl c in + let ce = mk_clenv_from gl (c,cty) in + unify_e_resolve false flags (c,ce) gl diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 deleted file mode 100644 index 4a5f0e2c..00000000 --- a/tactics/class_tactics.ml4 +++ /dev/null @@ -1,833 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Auto.create_hint_db false typeclasses_db full_transparent_state true) - -exception Found of evar_map - -(** 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_undefined - (fun ev evi (gls, evm') -> - 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 Some (List.rev goals, evm') - -(** Typeclasses instance search tactic / eauto *) - -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 - -open Unification - -let auto_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly_in_conv_on_closed_terms = true; - modulo_delta = var_full_transparent_state; - modulo_delta_types = full_transparent_state; - modulo_delta_in_merge = None; - check_applied_meta_types = false; - resolve_evars = false; - 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 = - match kind_of_term x, kind_of_term y with - | Evar (e1, l1), Evar (e2, l2) when e1 <> e2 -> true - | _, _ -> compare_constr eq_constr_mod_evars x y - -let progress_evars t gl = - let concl = pf_concl gl in - let check gl' = - let newconcl = pf_concl gl' in - if eq_constr_mod_evars concl newconcl - then tclFAIL 0 (str"No progress made (modulo evars)") gl' - else tclIDTAC gl' - in tclTHEN t check gl - -TACTIC EXTEND progress_evars - [ "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 ~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 ~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 - else - let ty = pf_type_of gls c in - let diff = nb_prod ty - nprods in - if diff >= 0 then - Some (mk_clenv_from_n gls (Some diff) (c,ty)) - else None - -let with_prods nprods (c, clenv) f gls = - match clenv_of_prods nprods (c, clenv) gls with - | None -> tclFAIL 0 (str"Not enough premisses") gls - | Some clenv' -> f (c, clenv') gls - -(** Hack to properly solve dependent evars that are typeclasses *) - -let flags_of_state st = - {auto_unif_flags with - 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 = - Eauto.registered_e_assumption :: - (tclTHEN Tactics.intro - (function g'-> - let d = pf_last_hyp g' in - 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))) - in - tclFIRST (List.map tclCOMPLETE tacl) goal - -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 - let hintl = - list_map_append - (fun db -> - if Hint_db.use_dn db then - let flags = flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> (flags, x)) (Hint_db.map_auto (hdc,concl) db) - else - let flags = flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> (flags, x)) (Hint_db.map_all hdc db)) - (local_db::db_list) - in - let tac_of_hint = - 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) - | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve flags) - | Give_exact (c) -> e_give_exact flags c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags)) - (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 -> -(* 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, 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)) true gl - with Bound | Not_found -> [] - -let e_possible_resolve db_list local_db gl = - try - e_my_find_search db_list local_db - (fst (head_constr_bound gl)) false gl - with Bound | Not_found -> [] - -let rec catchable = function - | Refiner.FailError _ -> true - | Loc.Exc_located (_, e) -> catchable e - | e -> Logic.catchable_exception e - -let nb_empty_evars s = - Evd.fold_undefined (fun ev evi acc -> succ acc) s 0 - -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; - 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 - -type atac = auto_result tac - -let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = - let cty = Evarutil.nf_evar sigma cty in - let rec iscl env ty = - let ctx, ar = decompose_prod_assum ty in - match kind_of_term (fst (decompose_app ar)) with - | Const c -> is_class (ConstRef c) - | Ind i -> is_class (IndRef i) - | _ -> - let env' = Environ.push_rel_context ctx env in - let ty' = whd_betadeltaiota env' ar in - if not (eq_constr ty' ar) then iscl env' ty' - else false - in - 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 = - 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 : (bool * 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 _ = - 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 (onlyc, sign', hints) - when onlyc = only_classes && - Environ.eq_named_context_val sign sign' -> hints - | _ -> let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in - unfreeze (Some (only_classes, sign, hints)); hints - -let 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 -> sk (f gls hints) fk - | None -> fk () } - -let intro_tac : atac = - lift_tactic Tactics.intro - (fun {it = gls; sigma = s} info -> - let gls' = - List.map (fun g' -> - 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 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 = - { 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 nbgoals s = - List.length (sig_it s) + nb_empty_evars (sig_sig s) - in - let pri = pri - pri' in - if pri <> 0 then pri - else nbgoals res - nbgoals 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 hints_tac hints = - { skft = fun sk fk {it = gl,info; sigma = s} -> - 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 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 - (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 list) fk = function - | (gl,info) :: gls -> - (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} fk -> - let rec aux' = function - | None -> fk () - | Some (res, s', 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 = - { skft = fun sk fk -> first.skft (then_list second sk) fk } - -let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = - t.skft (fun x _ -> Some x) (fun _ -> None) gl - -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 _ -> 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 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 (str"none"); - auto_path = []; auto_cut = cut }) - - -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 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, 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 hints goals evm') in - match get_result res with - | None -> raise Not_found - | Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true evm' evm, fk) - -let eauto_tac hints = - 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} -> - {it = List.map fst goals; sigma = s} - -let real_eauto st ?limit hints p evd = - let rec aux evd fails = - let res, 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 - | Some r -> res, fk :: fails - | None -> get_result (fk ()), fails) - fails (None, []) - in - match res with - | None -> evd - | Some (evd', fk) -> aux evd' (fk :: fails) - in aux evd [] - -let resolve_all_evars_once debug limit p evd = - let db = searchtable_map typeclasses_db in - 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) - -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 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' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in - let evd = sig_sig gls' 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) - -(** [split_evars] returns groups of undefined evars according to dependencies *) - -let split_evars evm = - 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 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 evd ev = - try - 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 - -(** Revert the resolvability status of evars after resolution, - potentially unprotecting some evars that were set unresolvable - just for this call to resolution. *) - -let revert_resolvability oevd evd = - Evd.fold_undefined - (fun ev evi evm -> - try - if not (Typeclasses.is_resolvable evi) then - let evi' = Evd.find_undefined oevd ev in - if Typeclasses.is_resolvable evi' then - Evd.add evm ev (Typeclasses.mark_resolvable evi) - else evm - else evm - with Not_found -> evm) - evd evd - -(** 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 in_comp comp ev = if do_split then Intset.mem ev comp else true - in - let rec docomp evd = function - | [] -> revert_resolvability oevd evd - | comp :: 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 initial_select_evars filter evd ev evi = - filter (snd evi.Evd.evar_source) && - Typeclasses.is_class_evar evd evi - -let resolve_typeclass_evars debug m env evd filter split fail = - let evd = - try Evarconv.consider_remaining_unif_problems - ~ts:(Typeclasses.classes_transparent_state ()) env evd - with e when Errors.noncritical e -> evd - in - resolve_all_evars debug m env (initial_select_evars filter) evd split fail - -let solve_inst debug depth env evd filter split fail = - resolve_typeclass_evars debug depth env evd filter split fail - -let _ = - Typeclasses.solve_instanciations_problem := - 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 false b) cl - -VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings -| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ - set_transparency cl true ] -END - -VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings -| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ - set_transparency cl false ] -END - -open Genarg -open Extraargs - -let pr_debug _prc _prlc _prt b = - if b then Pp.str "debug" else Pp.mt() - -ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug -| [ "debug" ] -> [ true ] -| [ ] -> [ false ] -END - -let pr_depth _prc _prlc _prt = function - Some i -> Util.pr_int i - | None -> Pp.mt() - -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) depth(depth) ] -> [ - set_typeclasses_debug d; - set_typeclasses_depth depth - ] -END - -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 e when Errors.noncritical e -> None) dbs - in - let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in - 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 ] -| [ "typeclasses" "eauto" ] -> [ typeclasses_eauto ~only_classes:true [typeclasses_db] ] -END - -let _ = Classes.refine_ref := Refine.refine - -(** Take the head of the arity of a constr. - Used in the partial application tactic. *) - -let rec head_of_constr t = - let t = strip_outer_cast(collapse_appl t) in - match kind_of_term t with - | Prod (_,_,c2) -> head_of_constr c2 - | LetIn (_,_,_,c2) -> head_of_constr c2 - | App (f,args) -> head_of_constr f - | _ -> t - -TACTIC EXTEND head_of_constr - [ "head_of_constr" ident(h) constr(c) ] -> [ - let c = head_of_constr c in - letin_tac None (Name h) c None allHyps - ] -END - -TACTIC EXTEND not_evar - [ "not_evar" constr(ty) ] -> [ - match kind_of_term ty with - | Evar _ -> tclFAIL 0 (str"Evar") - | _ -> tclIDTAC ] -END - -TACTIC EXTEND is_ground - [ "is_ground" constr(ty) ] -> [ fun gl -> - if Evarutil.is_ground_term (project gl) ty then tclIDTAC gl - else tclFAIL 0 (str"Not ground") gl ] -END - -TACTIC EXTEND autoapply - [ "autoapply" constr(c) "using" preident(i) ] -> [ fun gl -> - let flags = flags_of_state (Auto.Hint_db.transparent_state (Auto.searchtable_map i)) in - let cty = pf_type_of gl c in - let ce = mk_clenv_from gl (c,cty) in - unify_e_resolve flags (c,ce) gl ] -END diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli new file mode 100644 index 00000000..c6207ed6 --- /dev/null +++ b/tactics/class_tactics.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool + +val set_typeclasses_debug : bool -> unit +val get_typeclasses_debug : unit -> bool + +val set_typeclasses_depth : int option -> unit +val get_typeclasses_depth : unit -> int option + +val progress_evars : unit Proofview.tactic -> unit Proofview.tactic + +val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> + Hints.hint_db_name list -> tactic + +val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic + +val not_evar : constr -> unit Proofview.tactic + +val is_ground : constr -> tactic + +val autoapply : constr -> Hints.hint_db_name -> tactic diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 2a09f321..9ee14b80 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -1,90 +1,119 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let ida = pf_nth_hyp_id gl 1 - and idna = pf_nth_hyp_id gl 2 in - exact_no_check (applist(mkVar idna,[mkVar ida])) gl))); - tclIDTAC])); - tclIDTAC])) gls +let mk_absurd_proof t = + let id = Namegen.default_dependent_ident in + mkLambda (Names.Name id,mkApp(build_coq_not (),[|t|]), + mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) + +let absurd c = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let j = Retyping.get_judgment_of env sigma c in + let sigma, j = Coercion.inh_coerce_to_sort Loc.ghost env sigma j in + let t = j.Environ.utj_val in + Tacticals.New.tclTHENLIST [ + Proofview.Unsafe.tclEVARS sigma; + elim_type (build_coq_False ()); + Simple.apply (mk_absurd_proof t) + ] + end + +let absurd c = absurd c (* Contradiction *) -let filter_hyp f tac gl = +(** [f] does not assume its argument to be [nf_evar]-ed. *) +let filter_hyp f tac = let rec seek = function - | [] -> raise Not_found - | (id,_,t)::rest when f t -> tac id gl + | [] -> Proofview.tclZERO Not_found + | (id,_,t)::rest when f t -> tac id | _::rest -> seek rest in - seek (pf_hyps gl) + Proofview.Goal.enter begin fun gl -> + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + seek hyps + end -let contradiction_context gl = - let env = pf_env gl in - let sigma = project gl in - let rec seek_neg l gl = match l with - | [] -> error "No such contradiction" - | (id,_,typ)::rest -> - let typ = whd_betadeltaiota env sigma typ in - if is_empty_type typ then - simplest_elim (mkVar id) gl - else match kind_of_term typ with +let contradiction_context = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let rec seek_neg l = match l with + | [] -> Proofview.tclZERO (UserError ("" , Pp.str"No such contradiction")) + | (id,_,typ)::rest -> + let typ = nf_evar sigma typ in + let typ = whd_betadeltaiota env sigma typ in + if is_empty_type typ then + simplest_elim (mkVar id) + else match kind_of_term typ with | Prod (na,t,u) when is_empty_type u -> - (try - filter_hyp (fun typ -> pf_conv_x_leq gl typ t) - (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) - gl - with Not_found -> seek_neg rest gl) - | _ -> seek_neg rest gl in - seek_neg (pf_hyps gl) gl + (Proofview.tclORELSE + (Proofview.Goal.enter begin fun gl -> + let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in + filter_hyp (fun typ -> is_conv_leq typ t) + (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) + end) + begin function (e, info) -> match e with + | Not_found -> seek_neg rest + | e -> Proofview.tclZERO ~info e + end) + | _ -> seek_neg rest + in + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + seek_neg hyps + end let is_negation_of env sigma typ t = match kind_of_term (whd_betadeltaiota env sigma t) with - | Prod (na,t,u) -> is_empty_type u & is_conv_leq env sigma typ t + | Prod (na,t,u) -> + let u = nf_evar sigma u in + is_empty_type u && is_conv_leq env sigma typ t | _ -> false -let contradiction_term (c,lbind as cl) gl = - let env = pf_env gl in - let sigma = project gl in - let typ = pf_type_of gl c in - let _, ccl = splay_prod env sigma typ in - if is_empty_type ccl then - tclTHEN (elim false cl None) (tclTRY assumption) gl - else - try - if lbind = NoBindings then - filter_hyp (is_negation_of env sigma typ) - (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) gl - else - raise Not_found - with Not_found -> error "Not a contradiction." +let contradiction_term (c,lbind as cl) = + Proofview.Goal.nf_enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let type_of = Tacmach.New.pf_type_of gl in + let typ = type_of c in + let _, ccl = splay_prod env sigma typ in + if is_empty_type ccl then + Tacticals.New.tclTHEN + (elim false None cl None) + (Tacticals.New.tclTRY assumption) + else + Proofview.tclORELSE + begin + if lbind = NoBindings then + filter_hyp (is_negation_of env sigma typ) + (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) + else + Proofview.tclZERO Not_found + end + begin function (e, info) -> match e with + | Not_found -> Proofview.tclZERO (Errors.UserError ("",Pp.str"Not a contradiction.")) + | e -> Proofview.tclZERO ~info e + end + end let contradiction = function - | None -> tclTHEN intros contradiction_context + | None -> Tacticals.New.tclTHEN intros contradiction_context | Some c -> contradiction_term c diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli index 79da83e0..25d07e25 100644 --- a/tactics/contradiction.mli +++ b/tactics/contradiction.mli @@ -1,16 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* tactic -val contradiction : constr with_bindings option -> tactic +val absurd : constr -> unit Proofview.tactic +val contradiction : constr with_bindings option -> unit Proofview.tactic diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 new file mode 100644 index 00000000..5c039e72 --- /dev/null +++ b/tactics/coretactics.ml4 @@ -0,0 +1,229 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ Tactics.intros_reflexivity ] +END + +TACTIC EXTEND assumption + [ "assumption" ] -> [ Tactics.assumption ] +END + +TACTIC EXTEND etransitivity + [ "etransitivity" ] -> [ Tactics.intros_transitivity None ] +END + +TACTIC EXTEND cut + [ "cut" constr(c) ] -> [ Tactics.cut c ] +END + +TACTIC EXTEND exact_no_check + [ "exact_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.exact_no_check c) ] +END + +TACTIC EXTEND vm_cast_no_check + [ "vm_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.vm_cast_no_check c) ] +END + +TACTIC EXTEND casetype + [ "casetype" constr(c) ] -> [ Tactics.case_type c ] +END + +TACTIC EXTEND elimtype + [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ] +END + +TACTIC EXTEND lapply + [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ] +END + +TACTIC EXTEND transitivity + [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ] +END + +(** Left *) + +TACTIC EXTEND left + [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ] +END + +TACTIC EXTEND eleft + [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ] +END + +TACTIC EXTEND left_with + [ "left" "with" bindings(bl) ] -> [ + let { Evd.sigma = sigma ; it = bl } = bl in + Proofview.Unsafe.tclEVARS sigma <*> Tactics.left_with_bindings false bl + ] +END + +TACTIC EXTEND eleft_with + [ "eleft" "with" bindings(bl) ] -> [ + let { Evd.sigma = sigma ; it = bl } = bl in + Tacticals.New.tclWITHHOLES true (Tactics.left_with_bindings true) sigma bl + ] +END + +(** Right *) + +TACTIC EXTEND right + [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ] +END + +TACTIC EXTEND eright + [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ] +END + +TACTIC EXTEND right_with + [ "right" "with" bindings(bl) ] -> [ + let { Evd.sigma = sigma ; it = bl } = bl in + Proofview.Unsafe.tclEVARS sigma <*> Tactics.right_with_bindings false bl + ] +END + +TACTIC EXTEND eright_with + [ "eright" "with" bindings(bl) ] -> [ + let { Evd.sigma = sigma ; it = bl } = bl in + Tacticals.New.tclWITHHOLES true (Tactics.right_with_bindings true) sigma bl + ] +END + +(** Constructor *) + +TACTIC EXTEND constructor + [ "constructor" ] -> [ Tactics.any_constructor false None ] +| [ "constructor" int_or_var(i) ] -> [ + let i = Tacinterp.interp_int_or_var ist i in + Tactics.constructor_tac false None i NoBindings + ] +| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ + let { Evd.sigma = sigma; it = bl } = bl in + let i = Tacinterp.interp_int_or_var ist i in + let tac c = Tactics.constructor_tac false None i c in + Proofview.Unsafe.tclEVARS sigma <*> tac bl + ] +END + +TACTIC EXTEND econstructor + [ "econstructor" ] -> [ Tactics.any_constructor true None ] +| [ "econstructor" int_or_var(i) ] -> [ + let i = Tacinterp.interp_int_or_var ist i in + Tactics.constructor_tac true None i NoBindings + ] +| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ + let { Evd.sigma = sigma; it = bl } = bl in + let i = Tacinterp.interp_int_or_var ist i in + let tac c = Tactics.constructor_tac true None i c in + Tacticals.New.tclWITHHOLES true tac sigma bl + ] +END + +(** Specialize *) + +TACTIC EXTEND specialize + [ "specialize" constr_with_bindings(c) ] -> [ + let { Evd.sigma = sigma; it = c } = c in + let specialize c = Proofview.V82.tactic (Tactics.specialize c) in + Proofview.Unsafe.tclEVARS sigma <*> specialize c + ] +END + +TACTIC EXTEND symmetry + [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] +END + +(** Split *) + +TACTIC EXTEND split + [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] +END + +TACTIC EXTEND esplit + [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ] +END + +TACTIC EXTEND split_with + [ "split" "with" bindings(bl) ] -> [ + let { Evd.sigma = sigma ; it = bl } = bl in + Proofview.Unsafe.tclEVARS sigma <*> Tactics.split_with_bindings false [bl] + ] +END + +TACTIC EXTEND esplit_with + [ "esplit" "with" bindings(bl) ] -> [ + let { Evd.sigma = sigma ; it = bl } = bl in + Tacticals.New.tclWITHHOLES true (Tactics.split_with_bindings true) sigma [bl] + ] +END + +(** Intro *) + +TACTIC EXTEND intros_until + [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] +END + +(** Revert *) + +TACTIC EXTEND revert + [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ] +END + +(** Simple induction / destruct *) + +TACTIC EXTEND simple_induction + [ "simple" "induction" quantified_hypothesis(h) ] -> [ Tactics.simple_induct h ] +END + +TACTIC EXTEND simple_destruct + [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ] +END + +(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) + +open Tacexpr + +let initial_atomic () = + let dloc = Loc.ghost in + let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in + let iter (s, t) = + let body = TacAtom (dloc, t) in + Tacenv.register_ltac false false (Id.of_string s) body + in + let () = List.iter iter + [ "red", TacReduce(Red false,nocl); + "hnf", TacReduce(Hnf,nocl); + "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl); + "compute", TacReduce(Cbv Redops.all_flags,nocl); + "intro", TacIntroMove(None,MoveLast); + "intros", TacIntroPattern []; + "cofix", TacCofix None; + "trivial", TacTrivial (Off,[],None); + "auto", TacAuto(Off,None,[],None); + ] + in + let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in + List.iter iter + [ "idtac",TacId []; + "fail", TacFail(TacLocal,ArgArg 0,[]); + "fresh", TacArg(dloc,TacFreshId []) + ] + +let () = Mltop.declare_cache_obj initial_atomic "coretactics" diff --git a/tactics/dn.ml b/tactics/dn.ml index a0889ab8..3b1614d6 100644 --- a/tactics/dn.ml +++ b/tactics/dn.ml @@ -1,103 +1,101 @@ +open Util +type 'res lookup_res = Label of 'res | Nothing | Everything - - - -module Make = - functor (X : Set.OrderedType) -> +module Make = functor (Y : Map.OrderedType) -> functor (Z : Map.OrderedType) -> struct - + module Y_tries = struct type t = (Y.t * int) option - let compare x y = + let compare x y = match x,y with None,None -> 0 - | Some (l,n),Some (l',n') -> + | Some (l,n),Some (l',n') -> let m = Y.compare l l' in - if m = 0 then - n-n' + if Int.equal m 0 then + n-n' else m | Some(l,n),None -> 1 | None, Some(l,n) -> -1 end - module X_tries = struct - type t = X.t * Z.t - let compare (x1,x2) (y1,y2) = - let m = (X.compare x1 y1) in - if m = 0 then (Z.compare x2 y2) else - m + module ZSet = Set.Make(Z) + module X_tries = + struct + type t = ZSet.t + let nil = ZSet.empty + let is_nil = ZSet.is_empty + let add = ZSet.union + let sub = ZSet.diff end - module T = Tries.Make(X_tries)(Y_tries) - - type decompose_fun = X.t -> (Y.t * X.t list) option - - type 'res lookup_res = Label of 'res | Nothing | Everything - + module Trie = Trie.Make(Y_tries)(X_tries) + + type 'a decompose_fun = 'a -> (Y.t * 'a list) option + type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res - type t = T.t + type t = Trie.t - let create () = T.empty + let create () = Trie.empty -(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in +(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in prefix ordering, [dna] is the function returning the main node of a pattern *) let path_of dna = let rec path_of_deferred = function | [] -> [] | h::tl -> pathrec tl h - + and pathrec deferred t = match dna t with - | None -> + | None -> None :: (path_of_deferred deferred) | Some (lbl,[]) -> (Some (lbl,0))::(path_of_deferred deferred) | Some (lbl,(h::def_subl as v)) -> (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h) - in + in pathrec [] - + let tm_of tm lbl = - try [T.map tm lbl, true] with Not_found -> [] - + try [Trie.next tm lbl, true] with Not_found -> [] + let rec skip_arg n tm = - if n = 0 then [tm,true] + if Int.equal n 0 then [tm, true] else - List.flatten - (List.map - (fun a -> match a with - | None -> skip_arg (pred n) (T.map tm a) - | Some (lbl,m) -> - skip_arg (pred n + m) (T.map tm a)) - (T.dom tm)) - + let labels = Trie.labels tm in + let map lbl = match lbl with + | None -> skip_arg (pred n) (Trie.next tm lbl) + | Some (_, m) -> + skip_arg (pred n + m) (Trie.next tm lbl) + in + List.flatten (List.map map labels) + let lookup tm dna t = let rec lookrec t tm = match dna t with | Nothing -> tm_of tm None | Label(lbl,v) -> tm_of tm None@ - (List.fold_left - (fun l c -> + (List.fold_left + (fun l c -> List.flatten(List.map (fun (tm, b) -> if b then lookrec c tm else [tm,b]) l)) (tm_of tm (Some(lbl,List.length v))) v) | Everything -> skip_arg 1 tm - in - List.flatten (List.map (fun (tm,b) -> T.xtract tm) (lookrec t tm)) - + in + List.flatten (List.map (fun (tm,b) -> ZSet.elements (Trie.get tm)) (lookrec t tm)) + let add tm dna (pat,inf) = - let p = path_of dna pat in T.add tm (p,(pat,inf)) - + let p = path_of dna pat in Trie.add p (ZSet.singleton inf) tm + let rmv tm dna (pat,inf) = - let p = path_of dna pat in T.rmv tm (p,(pat,inf)) - - let app f tm = T.app (fun (_,p) -> f p) tm - + let p = path_of dna pat in Trie.remove p (ZSet.singleton inf) tm + + let app f tm = Trie.iter (fun _ p -> ZSet.iter f p) tm + end - + diff --git a/tactics/dn.mli b/tactics/dn.mli index 662ac19a..20407e9d 100644 --- a/tactics/dn.mli +++ b/tactics/dn.mli @@ -1,48 +1,39 @@ +type 'res lookup_res = Label of 'res | Nothing | Everything - - - - - -module Make : - functor (X : Set.OrderedType) -> +module Make : functor (Y : Map.OrderedType) -> functor (Z : Map.OrderedType) -> sig - type decompose_fun = X.t -> (Y.t * X.t list) option - + type 'a decompose_fun = 'a -> (Y.t * 'a list) option + type t val create : unit -> t - + (** [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 the list of its subtree *) - - val add : t -> decompose_fun -> X.t * Z.t -> t - - val rmv : t -> decompose_fun -> X.t * Z.t -> t - - type 'res lookup_res = Label of 'res | Nothing | Everything - + + val add : t -> 'a decompose_fun -> 'a * Z.t -> t + + val rmv : t -> 'a decompose_fun -> 'a * Z.t -> t + type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res - + (** [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 characterizing its root node and the list of its subtree *) - + val lookup : t -> 'term lookup_fun -> 'term - -> (X.t * Z.t) list - - val app : ((X.t * Z.t) -> unit) -> t -> unit - - val skip_arg : int -> t -> (t * bool) list - + -> Z.t list + + val app : (Z.t -> unit) -> t -> unit + end diff --git a/tactics/dnet.ml b/tactics/dnet.ml new file mode 100644 index 00000000..61a35866 --- /dev/null +++ b/tactics/dnet.ml @@ -0,0 +1,291 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'b) -> 'a t -> 'b t + val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t + val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a + val compare : unit t -> unit t -> int + val terminal : 'a t -> bool + val choose : ('a -> 'b) -> 'a t -> 'b +end + +module type S = +sig + type t + type ident + type meta + type 'a structure + module Idset : Set.S with type elt=ident + type term_pattern = + | Term of term_pattern structure + | Meta of meta + val empty : t + val add : t -> term_pattern -> ident -> t + val find_all : t -> Idset.t + val fold_pattern : + ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a + val find_match : term_pattern -> t -> Idset.t + val inter : t -> t -> t + val union : t -> t -> t + val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t +end + +module Make = + functor (T:Datatype) -> + functor (Ident:Set.OrderedType) -> + functor (Meta:Set.OrderedType) -> +struct + + type ident = Ident.t + type meta = Meta.t + + type 'a structure = 'a T.t + + type term_pattern = + | Term of term_pattern structure + | Meta of meta + + module Idset = Set.Make(Ident) + module Mmap = Map.Make(Meta) + module Tmap = Map.Make(struct type t = unit structure + let compare = T.compare end) + + type idset = Idset.t + + + + (* we store identifiers at the leaf of the dnet *) + type node = + | Node of t structure + | Terminal of t structure * idset + + (* at each node, we have a bunch of nodes (actually a map between + the bare node and a subnet) and a bunch of metavariables *) + and t = Nodes of node Tmap.t * idset Mmap.t + + let empty : t = Nodes (Tmap.empty, Mmap.empty) + + (* the head of a data is of type unit structure *) + let head w = T.map (fun c -> ()) w + + (* given a node of the net and a word, returns the subnet with the + same head as the word (with the rest of the nodes) *) + let split l (w:'a structure) : node * node Tmap.t = + let elt : node = Tmap.find (head w) l in + (elt, Tmap.remove (head w) l) + + let select l w = Tmap.find (head w) l + + let rec add (Nodes (t,m):t) (w:term_pattern) (id:ident) : t = + match w with Term w -> + ( try + let (n,tl) = split t w in + let new_node = match n with + | Terminal (e,is) -> Terminal (e,Idset.add id is) + | Node e -> Node (T.map2 (fun t p -> add t p id) e w) in + Nodes ((Tmap.add (head w) new_node tl), m) + with Not_found -> + let new_content = T.map (fun p -> add empty p id) w in + let new_node = + if T.terminal w then + Terminal (new_content, Idset.singleton id) + else Node new_content in + Nodes ((Tmap.add (head w) new_node t), m) ) + | Meta i -> + let m = + try Mmap.add i (Idset.add id (Mmap.find i m)) m + with Not_found -> Mmap.add i (Idset.singleton id) m in + Nodes (t, m) + + let add t w id = add t w id + + let rec find_all (Nodes (t,m)) : idset = + Idset.union + (Mmap.fold (fun _ -> Idset.union) m Idset.empty) + (Tmap.fold + ( fun _ n acc -> + let s2 = match n with + | Terminal (_,is) -> is + | Node e -> T.choose find_all e in + Idset.union acc s2 + ) t Idset.empty) + +(* (\* optimization hack: Not_found is catched in fold_pattern *\) *) +(* let fast_inter s1 s2 = *) +(* if Idset.is_empty s1 || Idset.is_empty s2 then raise Not_found *) +(* else Idset.inter s1 s2 *) + +(* let option_any2 f s1 s2 = match s1,s2 with *) +(* | Some s1, Some s2 -> f s1 s2 *) +(* | (Some s, _ | _, Some s) -> s *) +(* | _ -> raise Not_found *) + +(* let fold_pattern ?(complete=true) f acc pat dn = *) +(* let deferred = ref [] in *) +(* let leafs,metas = ref None, ref None in *) +(* let leaf s = leafs := match !leafs with *) +(* | None -> Some s *) +(* | Some s' -> Some (fast_inter s s') in *) +(* let meta s = metas := match !metas with *) +(* | None -> Some s *) +(* | Some s' -> Some (Idset.union s s') in *) +(* let defer c = deferred := c::!deferred in *) +(* let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = *) +(* Mmap.iter (fun _ -> meta) m; (\* TODO: gérer patterns nonlin ici *\) *) +(* match p with *) +(* | Meta m -> defer (m,dn) *) +(* | Term w -> *) +(* try match select t w with *) +(* | Terminal (_,is) -> leaf is *) +(* | Node e -> *) +(* if complete then T.fold2 (fun _ -> fp_rec) () w e else *) +(* if T.fold2 *) +(* (fun b p dn -> match p with *) +(* | Term _ -> fp_rec p dn; false *) +(* | Meta _ -> b *) +(* ) true w e *) +(* then T.choose (T.choose fp_rec w) e *) +(* with Not_found -> *) +(* if Mmap.is_empty m then raise Not_found else () *) +(* in try *) +(* fp_rec pat dn; *) +(* (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), *) +(* List.fold_left (fun acc (m,dn) -> f m dn acc) acc !deferred *) +(* with Not_found -> None,acc *) + + (* Sets with a neutral element for inter *) + module OSet (S:Set.S) = struct + type t = S.t option + let union s1 s2 : t = match s1,s2 with + | (None, _ | _, None) -> None + | Some a, Some b -> Some (S.union a b) + let inter s1 s2 : t = match s1,s2 with + | (None, a | a, None) -> a + | Some a, Some b -> Some (S.inter a b) + let is_empty : t -> bool = function + | None -> false + | Some s -> S.is_empty s + (* optimization hack: Not_found is catched in fold_pattern *) + let fast_inter s1 s2 = + if is_empty s1 || is_empty s2 then raise Not_found + else let r = inter s1 s2 in + if is_empty r then raise Not_found else r + let full = None + let empty = Some S.empty + end + + module OIdset = OSet(Idset) + + let fold_pattern ?(complete=true) f acc pat dn = + let deferred = ref [] in + let defer c = deferred := c::!deferred in + + let rec fp_rec metas p (Nodes(t,m) as dn:t) = + (* TODO gérer les dnets non-linéaires *) + let metas = Mmap.fold (fun _ -> Idset.union) m metas in + match p with + | Meta m -> defer (metas,m,dn); OIdset.full + | Term w -> + let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in + try match select t w with + | Terminal (_,is) -> Some (Idset.union curm is) + | Node e -> + let ids = if complete then T.fold2 + (fun acc w e -> + OIdset.fast_inter acc (fp_rec metas w e) + ) OIdset.full w e + else + let (all_metas, res) = T.fold2 + (fun (b,acc) w e -> match w with + | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e) + | Meta _ -> b, acc + ) (true,OIdset.full) w e in + if all_metas then T.choose (T.choose (fp_rec metas) w) e + else res in + OIdset.union ids (Some curm) + with Not_found -> + if Idset.is_empty metas then raise Not_found else Some curm in + let cand = + try fp_rec Idset.empty pat dn + with Not_found -> OIdset.empty in + let res = List.fold_left f acc !deferred in + cand, res + + (* intersection of two dnets. keep only the common pairs *) + let rec inter (t1:t) (t2:t) : t = + let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = + Nodes + (Tmap.fold + ( fun k e acc -> + try Tmap.add k (f e (Tmap.find k t2)) acc + with Not_found -> acc + ) t1 Tmap.empty, + Mmap.fold + ( fun m s acc -> + try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc + with Not_found -> acc + ) m1 Mmap.empty + ) in + inter_map + (fun n1 n2 -> match n1,n2 with + | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2) + | Node e1, Node e2 -> Node (T.map2 inter e1 e2) + | _ -> assert false + ) t1 t2 + + let rec union (t1:t) (t2:t) : t = + let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = + Nodes + (Tmap.fold + ( fun k e acc -> + try Tmap.add k (f e (Tmap.find k acc)) acc + with Not_found -> Tmap.add k e acc + ) t1 t2, + Mmap.fold + ( fun m s acc -> + try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc + with Not_found -> Mmap.add m s acc + ) m1 m2 + ) in + union_map + (fun n1 n2 -> match n1,n2 with + | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2) + | Node e1, Node e2 -> Node (T.map2 union e1 e2) + | _ -> assert false + ) t1 t2 + + let find_match (p:term_pattern) (t:t) : idset = + let metas = ref Mmap.empty in + let (mset,lset) = fold_pattern ~complete:false + (fun acc (mset,m,t) -> + let all = OIdset.fast_inter acc + (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in + metas := Mmap.add m t !metas; + find_all t)) in + OIdset.union (Some mset) all + ) None p t in + Option.get (OIdset.inter mset lset) + + let fold_pattern f acc p dn = fold_pattern ~complete:true f acc p dn + + let idset_map f is = Idset.fold (fun e acc -> Idset.add (f e) acc) is Idset.empty + let tmap_map f g m = Tmap.fold (fun k e acc -> Tmap.add (f k) (g e) acc) m Tmap.empty + + let rec map sidset sterm (Nodes (t,m)) : t = + let snode = function + | Terminal (e,is) -> Terminal (e,idset_map sidset is) + | Node e -> Node (T.map (map sidset sterm) e) in + Nodes (tmap_map sterm snode t, Mmap.map (idset_map sidset) m) + +end diff --git a/tactics/dnet.mli b/tactics/dnet.mli new file mode 100644 index 00000000..4bfa7263 --- /dev/null +++ b/tactics/dnet.mli @@ -0,0 +1,124 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* | Leaf + | Node of btree * btree | Node of 'a * 'a + +*) + +(** datatype you want to build a dnet on *) +module type Datatype = +sig + (** parametric datatype. ['a] is morally the recursive argument *) + type 'a t + + (** non-recursive mapping of subterms *) + val map : ('a -> 'b) -> 'a t -> 'b t + val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t + + (** non-recursive folding of subterms *) + val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a + + (** comparison of constructors *) + val compare : unit t -> unit t -> int + + (** for each constructor, is it not-parametric on 'a? *) + val terminal : 'a t -> bool + + (** [choose f w] applies f on ONE of the subterms of w *) + val choose : ('a -> 'b) -> 'a t -> 'b +end + +module type S = +sig + type t + + (** provided identifier type *) + type ident + + (** provided metavariable type *) + type meta + + (** provided parametrized datastructure *) + type 'a structure + + (** returned sets of solutions *) + module Idset : Set.S with type elt=ident + + (** a pattern is a term where each node can be a unification + variable *) + type term_pattern = + | Term of term_pattern structure + | Meta of meta + + val empty : t + + (** [add t w i] adds a new association (w,i) in t. *) + val add : t -> term_pattern -> ident -> t + + (** [find_all t] returns all identifiers contained in t. *) + val find_all : t -> Idset.t + + (** [fold_pattern f acc p dn] folds f on each meta of p, passing the + meta and the sub-dnet under it. The result includes: + - Some set if identifiers were gathered on the leafs of the term + - None if the pattern contains no leaf (only Metas at the leafs). + *) + val fold_pattern : + ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a + + (** [find_match p t] returns identifiers of all terms matching p in + t. *) + val find_match : term_pattern -> t -> Idset.t + + (** set operations on dnets *) + val inter : t -> t -> t + val union : t -> t -> t + + (** apply a function on each identifier and node of terms in a dnet *) + val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t +end + +module Make : + functor (T:Datatype) -> + functor (Ident:Set.OrderedType) -> + functor (Meta:Set.OrderedType) -> + S with type ident = Ident.t + and type meta = Meta.t + and type 'a structure = 'a T.t diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 144100c9..30c5e686 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -1,40 +1,42 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ e_assumption ] +| [ "eassumption" ] -> [ Proofview.V82.tactic e_assumption ] END TACTIC EXTEND eexact -| [ "eexact" constr(c) ] -> [ e_give_exact c ] +| [ "eexact" constr(c) ] -> [ Proofview.V82.tactic (e_give_exact c) ] END let registered_e_assumption gl = @@ -57,10 +59,29 @@ let registered_e_assumption gl = (* PROLOG tactic *) (************************************************************************) +(*s Tactics handling a list of goals. *) + +(* first_goal : goal list sigma -> goal sigma *) + +let first_goal gls = + let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in + if List.is_empty gl then error "first_goal"; + { Evd.it = List.hd gl; Evd.sigma = sig_0; } + +(* tactic -> tactic_list : Apply a tactic to the first goal in the list *) + +let apply_tac_list tac glls = + let (sigr,lg) = unpackage glls in + match lg with + | (g1::rest) -> + let gl = apply_sig_tac sigr tac g1 in + repackage sigr (gl@rest) + | _ -> error "apply_tac_list" + let one_step l gl = - [Tactics.intro] - @ (List.map h_simplest_eapply (List.map mkVar (pf_ids_of_hyps gl))) - @ (List.map h_simplest_eapply l) + [Proofview.V82.of_tactic Tactics.intro] + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl))) + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l) @ (List.map assumption (pf_ids_of_hyps gl)) let rec prolog l n gl = @@ -68,11 +89,15 @@ let rec prolog l n gl = let prol = (prolog l (n-1)) in (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl +let out_term = function + | IsConstr (c, _) -> c + | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) + let prolog_tac l n gl = - let l = List.map (prepare_hint (pf_env gl)) l in + let l = List.map (fun x -> out_term (pf_apply (prepare_hint false) gl x)) l in let n = match n with - | ArgArg n -> n + | ArgArg n -> n | _ -> error "Prolog called with a non closed argument." in try (prolog l n gl) @@ -80,7 +105,7 @@ let prolog_tac l n gl = errorlabstrm "Prolog.prolog" (str "Prolog failed.") TACTIC EXTEND prolog -| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ] +| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ Proofview.V82.tactic (prolog_tac l n) ] END open Auto @@ -90,17 +115,26 @@ open Unification (* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) (***************************************************************************) -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 ~flags clenv' gls in - h_simplest_eapply c gls - +let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) + +let unify_e_resolve poly flags (c,clenv) gls = + let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst in + let clenv' = connect_clenv gls clenv' in + let clenv' = clenv_unique_resolver ~flags clenv' gls in + tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) + (Proofview.V82.of_tactic (Tactics.Simple.eapply (Vars.subst_univs_level_constr subst c))) gls + +let e_exact poly flags (c,clenv) = + let clenv', subst = + if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst + in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c) + let rec e_trivial_fail_db db_list local_db goal = let tacl = registered_e_assumption :: - (tclTHEN Tactics.intro + (tclTHEN (Proofview.V82.of_tactic Tactics.intro) (function g'-> let d = pf_last_hyp g' in let hintl = make_resolve_hyp (pf_env g') (project g') d in @@ -108,43 +142,35 @@ let rec e_trivial_fail_db db_list local_db goal = (Hint_db.add_list hintl local_db) g'))) :: (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) in - tclFIRST (List.map tclCOMPLETE tacl) goal + tclFIRST (List.map tclCOMPLETE tacl) goal and e_my_find_search db_list local_db hdc concl = - let hdc = head_of_constr_reference hdc in let hintl = if occur_existential concl then - list_map_append (fun db -> - let flags = {auto_unif_flags with modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list) + List.map_append (fun db -> + let flags = auto_flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> flags, x) (Hint_db.map_existential hdc concl db) + (* FIXME: should be (Hint_db.map_eauto hdc concl db) *)) (local_db::db_list) else - list_map_append (fun db -> - let flags = {auto_unif_flags with modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) + List.map_append (fun db -> + let flags = auto_flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> flags, x) (Hint_db.map_auto hdc concl db)) (local_db::db_list) in let tac_of_hint = - fun (st, {pri=b; pat = p; code=t}) -> + fun (st, {pri = b; pat = p; code = t; poly = poly}) -> (b, let tac = match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve st (term,cl) - | Give_exact (c) -> e_give_exact c + | Res_pf (term,cl) -> Proofview.V82.of_tactic (unify_resolve poly st (term,cl)) + | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) + | Give_exact (c,cl) -> e_exact poly st (c,cl) | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve st (term,cl)) + tclTHEN (unify_e_resolve poly st (term,cl)) (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> h_reduce (Unfold [all_occurrences_expr,c]) onConcl - | Extern tacast -> conclPattern concl p tacast + | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl + | Extern tacast -> Proofview.V82.of_tactic (conclPattern concl p tacast) in (tac,lazy (pr_autotactic t))) - (*i - fun gls -> pPNL (pr_autotactic t); Format.print_flush (); - try tac gls - with e when Logic.catchable_exception(e) -> - (Format.print_string "Fail\n"; - Format.print_flush (); - raise e) - i*) in List.map tac_of_hint hintl @@ -152,13 +178,13 @@ and e_trivial_resolve db_list local_db gl = try priority (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) + (decompose_app_bound gl) gl) with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try List.map snd (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) + (decompose_app_bound gl) gl) with Bound | Not_found -> [] let find_first_goal gls = @@ -171,8 +197,8 @@ type search_state = { depth : int; (*r depth of search before failing *) tacres : goal list sigma; last_tactic : std_ppcmds Lazy.t; - dblist : Auto.hint_db list; - localdb : Auto.hint_db list; + dblist : hint_db list; + localdb : hint_db list; prev : prev_search_state } @@ -185,13 +211,9 @@ module SearchProblem = struct type state = search_state - let success s = (sig_it s.tacres) = [] + let success s = List.is_empty (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_evar_map (Refiner.project gls) in - prlist (pr_ev evars) (sig_it gls) +(* let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) *) let filter_tactics glls l = (* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) @@ -206,6 +228,7 @@ module SearchProblem = struct (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) (lgls,pptac) :: aux tacl with e when Errors.noncritical e -> + let e = Errors.push e in Refiner.catch_failerror e; aux tacl in aux l @@ -214,13 +237,13 @@ module SearchProblem = struct let compare s s' = let d = s'.depth - s.depth in let nbgoals s = List.length (sig_it s.tacres) in - if d <> 0 then d else nbgoals s - nbgoals s' + if not (Int.equal d 0) then d else nbgoals s - nbgoals s' let branching s = - if s.depth = 0 then + if Int.equal s.depth 0 then [] else - let ps = if s.prev = Unknown then Unknown else State s in + let ps = if s.prev == Unknown then Unknown else State s in let lg = s.tacres in let nbgl = List.length (sig_it lg) in assert (nbgl > 0); @@ -249,7 +272,7 @@ module SearchProblem = struct { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = ldb :: List.tl s.localdb; prev = ps }) - (filter_tactics s.tacres [Tactics.intro,lazy (str "intro")]) + (filter_tactics s.tacres [Proofview.V82.of_tactic Tactics.intro,lazy (str "intro")]) in let rec_tacs = let l = @@ -262,10 +285,18 @@ module SearchProblem = struct { depth = s.depth; tacres = res; last_tactic = pp; prev = ps; dblist = s.dblist; localdb = List.tl s.localdb } else - { depth = pred s.depth; tacres = res; - dblist = s.dblist; last_tactic = pp; prev = ps; - localdb = - list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }) + let newlocal = + let hyps = pf_hyps g in + List.map (fun gl -> + let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in + let hyps' = pf_hyps gls in + if hyps' == hyps then List.hd s.localdb + else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true []) + (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) + in + { depth = pred s.depth; tacres = res; + dblist = s.dblist; last_tactic = pp; prev = ps; + localdb = newlocal @ List.tl s.localdb }) l in List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) @@ -301,8 +332,8 @@ let _ = Goptions.optwrite = (:=) global_info_eauto } let mk_eauto_dbg d = - if d = Debug || !global_debug_eauto then Debug - else if d = Info || !global_info_eauto then Info + if d == Debug || !global_debug_eauto then Debug + else if d == Info || !global_info_eauto then Info else Off let pr_info_nop = function @@ -315,7 +346,7 @@ let pr_dbg_header = function | Info -> msg_debug (str "(* info eauto : *)") let pr_info dbg s = - if dbg <> Info then () + if dbg != Info then () else let rec loop s = match s.prev with @@ -336,11 +367,11 @@ let make_initial_state dbg n gl dblist localdb = last_tactic = lazy (mt()); dblist = dblist; localdb = [localdb]; - prev = if dbg=Info then Init else Unknown; + prev = if dbg == Info then Init else Unknown; } let e_search_auto debug (in_depth,p) lems db_list gl = - let local_db = make_local_hint_db ~ts:full_transparent_state true lems gl in + let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in let d = mk_eauto_dbg debug in let tac = match in_depth,d with | (true,Debug) -> Search.debug_depth_first @@ -357,7 +388,8 @@ let e_search_auto debug (in_depth,p) lems db_list gl = pr_info_nop d; error "eauto: search failed" -open Evd +(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) +(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) let eauto_with_bases ?(debug=Off) np lems db_list = tclTRY (e_search_auto debug np lems db_list) @@ -368,8 +400,8 @@ let eauto ?(debug=Off) np lems dbnames = let full_eauto ?(debug=Off) n lems gl = let dbnames = current_db_names () in - let dbnames = list_remove "v62" dbnames in - let db_list = List.map searchtable_map dbnames in + let dbnames = String.Set.remove "v62" dbnames in + let db_list = List.map searchtable_map (String.Set.elements dbnames) in tclTRY (e_search_auto debug n lems db_list) gl let gen_eauto ?(debug=Off) np lems = function @@ -422,7 +454,7 @@ END TACTIC EXTEND eauto | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ gen_eauto (make_dimension n p) lems db ] + [ Proofview.V82.tactic (gen_eauto (make_dimension n p) lems db) ] END TACTIC EXTEND new_eauto @@ -436,64 +468,70 @@ END TACTIC EXTEND debug_eauto | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ gen_eauto ~debug:Debug (make_dimension n p) lems db ] + [ Proofview.V82.tactic (gen_eauto ~debug:Debug (make_dimension n p) lems db) ] END TACTIC EXTEND info_eauto | [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ gen_eauto ~debug:Info (make_dimension n p) lems db ] + [ Proofview.V82.tactic (gen_eauto ~debug:Info (make_dimension n p) lems db) ] END TACTIC EXTEND dfs_eauto | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ gen_eauto (true, make_depth p) lems db ] + [ Proofview.V82.tactic (gen_eauto (true, make_depth p) lems db) ] END let cons a l = a :: l -let autounfolds db occs = +let autounfolds db occs cls gl = let unfolds = List.concat (List.map (fun dbname -> let db = try searchtable_map dbname with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in - Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts - (Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) - in unfold_option unfolds + let hyps = pf_ids_of_hyps gl in + let ids = Idset.filter (fun id -> List.mem id hyps) ids in + Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts + (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) + in unfold_option unfolds cls gl let autounfold db cls gl = - let cls = concrete_clause_of cls gl in + let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in let tac = autounfolds db in tclMAP (function | OnHyp (id,occs,where) -> tac occs (Some (id,where)) | OnConcl occs -> tac occs None) cls gl -open Extraargs +let autounfold_tac db cls gl = + let dbs = match db with + | None -> String.Set.elements (current_db_names ()) + | Some [] -> ["core"] + | Some l -> l + in + autounfold dbs cls gl TACTIC EXTEND autounfold -| [ "autounfold" hintbases(db) in_arg_hyp(id) ] -> - [ autounfold (match db with None -> Auto.current_db_names () | Some [] -> ["core"] | Some x -> x) - (glob_in_arg_hyp_to_clause id) ] +| [ "autounfold" hintbases(db) clause(cl) ] -> [ Proofview.V82.tactic (autounfold_tac db cl) ] END let unfold_head env (ids, csts) c = let rec aux c = match kind_of_term c with - | Var id when Idset.mem id ids -> + | Var id when Id.Set.mem id ids -> (match Environ.named_body id env with | Some b -> true, b | None -> false, c) - | Const cst when Cset.mem cst csts -> - true, Environ.constant_value env cst + | Const (cst,u as c) when Cset.mem cst csts -> + true, Environ.constant_value_in env c | App (f, args) -> (match aux f with | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) | false, _ -> let done_, args' = - array_fold_left_i (fun i (done_, acc) arg -> + Array.fold_left_i (fun i (done_, acc) arg -> if done_ then done_, arg :: acc else match aux arg with | true, arg' -> true, arg' :: acc @@ -511,24 +549,30 @@ let unfold_head env (ids, csts) c = in !done_, c' in aux c -let autounfold_one db cl gl = +let autounfold_one db cl = + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in let st = List.fold_left (fun (i,c) dbname -> let db = try searchtable_map dbname with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in - (Idset.union ids i, Cset.union csts c)) (Idset.empty, Cset.empty) db + (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db + in + let did, c' = unfold_head env st + (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) in - let did, c' = unfold_head (pf_env gl) st (match cl with Some (id, _) -> pf_get_hyp_typ gl id | None -> pf_concl gl) in if did then match cl with - | Some hyp -> change_in_hyp None c' hyp gl - | None -> convert_concl_no_check c' DEFAULTcast gl - else tclFAIL 0 (str "Nothing to unfold") gl + | Some hyp -> change_in_hyp None (fun sigma -> sigma, c') hyp + | None -> convert_concl_no_check c' DEFAULTcast + else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") + end (* Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts *) -(* (Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *) +(* (Id.Set.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *) (* in unfold_option unfolds cl *) (* let db = try searchtable_map dbname *) @@ -536,7 +580,7 @@ let autounfold_one db cl gl = (* in *) (* let (ids, csts) = Hint_db.unfolds db in *) (* Cset.fold (fun cst -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cst)) csts *) -(* (Idset.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *) +(* (Id.Set.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *) (* (tclFAIL 0 (mt())) db *) TACTIC EXTEND autounfold_one @@ -548,16 +592,26 @@ TACTIC EXTEND autounfold_one TACTIC EXTEND autounfoldify | [ "autounfoldify" constr(x) ] -> [ + Proofview.V82.tactic ( let db = match kind_of_term x with - | Const c -> string_of_label (con_label c) + | Const (c,_) -> Label.to_string (con_label c) | _ -> assert false - in autounfold ["core";db] onConcl ] + in autounfold ["core";db] onConcl + )] END TACTIC EXTEND unify | ["unify" constr(x) constr(y) ] -> [ unify x y ] | ["unify" constr(x) constr(y) "with" preident(base) ] -> [ - unify ~state:(Hint_db.transparent_state (searchtable_map base)) x y ] + let table = try Some (searchtable_map base) with Not_found -> None in + match table with + | None -> + let msg = str "Hint table " ++ str base ++ str " not found" in + Proofview.tclZERO (UserError ("", msg)) + | Some t -> + let state = Hint_db.transparent_state t in + unify ~state x y + ] END @@ -570,7 +624,7 @@ let pr_hints_path_atom prc _ _ a = match a with | PathAny -> str"." | PathHints grs -> - prlist_with_sep pr_spc Printer.pr_global grs + pr_sequence Printer.pr_global grs ARGUMENT EXTEND hints_path_atom TYPED AS hints_path_atom @@ -610,9 +664,9 @@ ARGUMENT EXTEND opthints | [ ] -> [ None ] END -VERNAC COMMAND EXTEND HintCut +VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF | [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ let entry = HintsCutEntry p in - Auto.add_hints (Vernacexpr.use_section_locality ()) + Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) (match dbnames with None -> ["core"] | Some l -> l) entry ] END diff --git a/tactics/eauto.mli b/tactics/eauto.mli index bfe52d9a..19e2f198 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool * int -> open_constr list -> val eauto_with_bases : ?debug:Tacexpr.debug -> bool * int -> - open_constr list -> Auto.hint_db list -> Proof_type.tactic + open_constr list -> hint_db list -> Proof_type.tactic -val autounfold : hint_db_name list -> Tacticals.clause -> tactic +val autounfold : hint_db_name list -> Locus.clause -> tactic diff --git a/tactics/elim.ml b/tactics/elim.ml index ea5b4eed..b7d5b102 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -1,35 +1,28 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* if b then acc+2 else acc+1) - 0 ba.branchsign + 0 ba.Tacticals.branchsign in let introElimAssums = tclDO nassums intro in (tclTHEN introElimAssums (elim_on_ba tac ba)) @@ -38,17 +31,17 @@ let introCaseAssumsThen tac ba = let case_thin_sign = List.flatten (List.map (function b -> if b then [false;true] else [false]) - ba.branchsign) + ba.Tacticals.branchsign) in let n1 = List.length case_thin_sign in - let n2 = List.length ba.branchnames in + let n2 = List.length ba.Tacticals.branchnames in let (l1,l2),l3 = - if n1 < n2 then list_chop n1 ba.branchnames, [] + if n1 < n2 then List.chop n1 ba.Tacticals.branchnames, [] else - (ba.branchnames, []), - if n1 > n2 then snd (list_chop n2 case_thin_sign) else [] in + (ba.Tacticals.branchnames, []), + if n1 > n2 then snd (List.chop n2 case_thin_sign) else [] in let introCaseAssums = - tclTHEN (intros_pattern no_move l1) (intros_clearing l3) in + tclTHEN (intro_patterns l1) (intros_clearing l3) in (tclTHEN introCaseAssums (case_on_ba (tac l2) ba)) (* The following tactic Decompose repeatedly applies the @@ -69,118 +62,120 @@ Another example : Qed. *) -let elimHypThen tac id gl = - elimination_then tac ([],[]) (mkVar id) gl +let elimHypThen tac id = + elimination_then tac (mkVar id) let rec general_decompose_on_hyp recognizer = - ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> tclIDTAC) + ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> Proofview.tclUNIT()) and general_decompose_aux recognizer id = elimHypThen (introElimAssumsThen (fun bas -> - tclTHEN (clear [id]) + tclTHEN (Proofview.V82.tactic (clear [id])) (tclMAP (general_decompose_on_hyp recognizer) - (ids_of_named_context bas.assums)))) + (ids_of_named_context bas.Tacticals.assums)))) id -(* Faudrait ajouter un COMPLETE pour que l'hypothèse créée ne reste - pas si aucune élimination n'est possible *) +(* We should add a COMPLETE to be sure that the created hypothesis + doesn't stay if no elimination is possible *) -(* Meilleures stratégies mais perte de compatibilité *) -let tmphyp_name = id_of_string "_TmpHyp" +(* Best strategies but loss of compatibility *) +let tmphyp_name = Id.of_string "_TmpHyp" let up_to_delta = ref false (* true *) -let general_decompose recognizer c gl = - let typc = pf_type_of gl c in - tclTHENSV (cut typc) - [| tclTHEN (intro_using tmphyp_name) +let general_decompose recognizer c = + Proofview.Goal.enter begin fun gl -> + let type_of = pf_type_of gl in + let typc = type_of c in + tclTHENS (cut typc) + [ tclTHEN (intro_using tmphyp_name) (onLastHypId (ifOnHyp recognizer (general_decompose_aux recognizer) - (fun id -> clear [id]))); - exact_no_check c |] gl + (fun id -> Proofview.V82.tactic (clear [id])))); + Proofview.V82.tactic (exact_no_check c) ] + end -let head_in gls indl t = +let head_in indl t gl = + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in try let ity,_ = if !up_to_delta - then find_mrectype (pf_env gls) (project gls) t + then find_mrectype env sigma t else extract_mrectype t - in List.mem ity indl + in List.exists (fun i -> eq_ind (fst i) (fst ity)) indl with Not_found -> false -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 +let decompose_these c l = + Proofview.Goal.enter begin fun gl -> + let indl = List.map (fun x -> x, Univ.Instance.empty) l in + general_decompose (fun (_,t) -> head_in indl t gl) c + end -let decompose_nonrec c gls = - general_decompose - (fun (_,t) -> is_non_recursive_type t) - c gls - -let decompose_and c gls = +let decompose_and c = general_decompose (fun (_,t) -> is_record t) - c gls + c -let decompose_or c gls = +let decompose_or c = general_decompose (fun (_,t) -> is_disjunction t) - c gls + c -let h_decompose l c = - Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l) +let h_decompose l c = decompose_these c l -let h_decompose_or c = - Refiner.abstract_tactic (TacDecomposeOr c) (decompose_or c) +let h_decompose_or = decompose_or -let h_decompose_and c = - Refiner.abstract_tactic (TacDecomposeAnd c) (decompose_and c) +let h_decompose_and = decompose_and (* The tactic Double performs a double induction *) -let simple_elimination c gls = - simple_elimination_then (fun _ -> tclIDTAC) c gls +let simple_elimination c = + elimination_then (fun _ -> tclIDTAC) c let induction_trailer abs_i abs_j bargs = tclTHEN (tclDO (abs_j - abs_i) intro) (onLastHypId - (fun id gls -> - let idty = pf_type_of gls (mkVar id) in - let fvty = global_vars (pf_env gls) idty in + (fun id -> + Proofview.Goal.nf_enter begin fun gl -> + let idty = pf_type_of gl (mkVar id) in + let fvty = global_vars (pf_env gl) idty in let possible_bring_hyps = - (List.tl (nLastDecls (abs_j - abs_i) gls)) @ bargs.assums + (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums in let (hyps,_) = List.fold_left - (fun (bring_ids,leave_ids) (cid,_,cidty as d) -> + (fun (bring_ids,leave_ids) (cid,_,_ as d) -> if not (List.mem cid leave_ids) then (d::bring_ids,leave_ids) else (bring_ids,cid::leave_ids)) ([],fvty) possible_bring_hyps in let ids = List.rev (ids_of_named_context hyps) in - (tclTHENSEQ - [bring_hyps hyps; tclTRY (clear ids); + (tclTHENLIST + [bring_hyps hyps; tclTRY (Proofview.V82.tactic (clear ids)); simple_elimination (mkVar id)]) - gls)) - -let double_ind h1 h2 gls = - let abs_i = depth_of_quantified_hypothesis true h1 gls in - let abs_j = depth_of_quantified_hypothesis true h2 gls in - let (abs_i,abs_j) = - if abs_i < abs_j then (abs_i,abs_j) else - if abs_i > abs_j then (abs_j,abs_i) else - error "Both hypotheses are the same." in + end + )) + +let double_ind h1 h2 = + Proofview.Goal.nf_enter begin fun gl -> + let abs_i = of_old (depth_of_quantified_hypothesis true h1) gl in + let abs_j = of_old (depth_of_quantified_hypothesis true h2) gl in + let abs = + if abs_i < abs_j then Proofview.tclUNIT (abs_i,abs_j) else + if abs_i > abs_j then Proofview.tclUNIT (abs_j,abs_i) else + tclZEROMSG (Pp.str "Both hypotheses are the same.") in + abs >>= fun (abs_i,abs_j) -> (tclTHEN (tclDO abs_i intro) (onLastHypId (fun id -> elimination_then - (introElimAssumsThen (induction_trailer abs_i abs_j)) - ([],[]) (mkVar id)))) gls + (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id)))) + end -let h_double_induction h1 h2 = - Refiner.abstract_tactic (TacDoubleInduction (h1,h2)) (double_ind h1 h2) +let h_double_induction = double_ind diff --git a/tactics/elim.mli b/tactics/elim.mli index 2c6b8d96..8e98646e 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* tactic) -> branch_args -> tactic - val introCaseAssumsThen : - (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) -> - branch_args -> tactic - -val general_decompose : (identifier * constr -> bool) -> constr -> tactic -val decompose_nonrec : constr -> tactic -val decompose_and : constr -> tactic -val decompose_or : constr -> tactic -val h_decompose : inductive list -> constr -> tactic -val h_decompose_or : constr -> tactic -val h_decompose_and : constr -> tactic + (Tacexpr.intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> + branch_args -> unit Proofview.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 +val h_decompose : inductive list -> constr -> unit Proofview.tactic +val h_decompose_or : constr -> unit Proofview.tactic +val h_decompose_and : constr -> unit Proofview.tactic +val h_double_induction : quantified_hypothesis -> quantified_hypothesis-> unit Proofview.tactic diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index df4c0ebc..749e0d2b 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* build_induction_scheme_in_type false InType x, Declareops.no_seff) let rect_scheme_kind_from_prop = declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" - (build_induction_scheme_in_type false InType) + (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) let rect_dep_scheme_kind_from_type = declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" - (build_induction_scheme_in_type true InType) - -let rect_dep_scheme_kind_from_prop = - declare_individual_scheme_object "_rect_dep" - (build_induction_scheme_in_type true InType) + (fun x -> build_induction_scheme_in_type true InType x, Declareops.no_seff) let ind_scheme_kind_from_type = declare_individual_scheme_object "_ind_nodep" @@ -74,14 +90,6 @@ let ind_dep_scheme_kind_from_type = declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InProp) -let ind_dep_scheme_kind_from_prop = - declare_individual_scheme_object "_ind_dep" - (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_prop true InProp) - -let rec_scheme_kind_from_type = - declare_individual_scheme_object "_rec_nodep" - (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InSet) - let rec_scheme_kind_from_prop = declare_individual_scheme_object "_rec" ~aux:"_rec_from_prop" (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InSet) @@ -90,35 +98,35 @@ let rec_dep_scheme_kind_from_type = declare_individual_scheme_object "_rec" ~aux:"_rec_from_type" (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InSet) -let rec_dep_scheme_kind_from_prop = - declare_individual_scheme_object "_rec_dep" - (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_prop true InSet) - (* Case analysis *) let build_case_analysis_scheme_in_type dep sort ind = - build_case_analysis_scheme (Global.env()) Evd.empty ind dep sort + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, indu = Evd.fresh_inductive_instance env sigma ind in + let sigma, c = build_case_analysis_scheme env sigma indu dep sort in + c, Evd.evar_universe_context sigma let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" - (build_case_analysis_scheme_in_type false InType) + (fun x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff) let case_scheme_kind_from_prop = declare_individual_scheme_object "_case" ~aux:"_case_from_prop" - (build_case_analysis_scheme_in_type false InType) + (fun x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff) let case_dep_scheme_kind_from_type = declare_individual_scheme_object "_case" ~aux:"_case_from_type" - (build_case_analysis_scheme_in_type true InType) + (fun x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff) let case_dep_scheme_kind_from_type_in_prop = declare_individual_scheme_object "_casep_dep" - (build_case_analysis_scheme_in_type true InProp) + (fun x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff) let case_dep_scheme_kind_from_prop = declare_individual_scheme_object "_case_dep" - (build_case_analysis_scheme_in_type true InType) + (fun x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff) let case_dep_scheme_kind_from_prop_in_prop = declare_individual_scheme_object "_casep" - (build_case_analysis_scheme_in_type true InProp) + (fun x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff) diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index c747b843..0b843b8f 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (clear [destVar c]))) + +let choose_eq eqonleft = + if eqonleft then + left_with_bindings false Misctypes.NoBindings + else + right_with_bindings false Misctypes.NoBindings +let choose_noteq eqonleft = + if eqonleft then + right_with_bindings false Misctypes.NoBindings + else + left_with_bindings false Misctypes.NoBindings + +let mkBranches c1 c2 = + tclTHENLIST + [Proofview.V82.tactic (generalize [c2]); + Simple.elim c1; + intros; + onLastHyp Simple.case; + clear_last; + intros] + +let solveNoteqBranch side = + tclTHEN (choose_noteq side) + (tclTHEN introf + (onLastHypId (fun id -> Extratactics.discrHyp id))) + +(* Constructs the type {c1=c2}+{~c1=c2} *) + +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + +let mkDecideEqGoal eqonleft op rectype c1 c2 = + let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in + let disequality = mkApp(build_coq_not (), [|equality|]) in + if eqonleft then mkApp(op, [|equality; disequality |]) + else mkApp(op, [|disequality; equality |]) + + +(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) + +let idx = Id.of_string "x" +let idy = Id.of_string "y" + +let mkGenDecideEqGoal rectype g = + let hypnames = pf_ids_of_hyps g in + let xname = next_ident_away idx hypnames + and yname = next_ident_away idy hypnames in + (mkNamedProd xname rectype + (mkNamedProd yname rectype + (mkDecideEqGoal true (build_coq_sumbool ()) + rectype (mkVar xname) (mkVar yname)))) + +let eqCase tac = + (tclTHEN intro + (tclTHEN (onLastHyp Equality.rewriteLR) + (tclTHEN clear_last + tac))) + +let diseqCase eqonleft = + let diseq = Id.of_string "diseq" in + let absurd = Id.of_string "absurd" in + (tclTHEN (intro_using diseq) + (tclTHEN (choose_noteq eqonleft) + (tclTHEN (Proofview.V82.tactic red_in_concl) + (tclTHEN (intro_using absurd) + (tclTHEN (Simple.apply (mkVar diseq)) + (tclTHEN (Extratactics.injHyp absurd) + (full_trivial []))))))) + +open Proofview.Notations + +(* spiwack: a small wrapper around [Hipattern]. *) + +let match_eqdec c = + try Proofview.tclUNIT (match_eqdec c) + with PatternMatchingFailure -> Proofview.tclZERO PatternMatchingFailure + +(* /spiwack *) + +let solveArg eqonleft op a1 a2 tac = + Proofview.Goal.enter begin fun gl -> + let rectype = pf_type_of gl a1 in + let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in + let subtacs = + if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto] + else [diseqCase eqonleft;eqCase tac;default_auto] in + (tclTHENS (elim_type decide) subtacs) + end + +let solveEqBranch rectype = + Proofview.tclORELSE + begin + Proofview.Goal.enter begin fun gl -> + let concl = pf_nf_concl gl in + match_eqdec concl >>= fun (eqonleft,op,lhs,rhs,_) -> + let (mib,mip) = Global.lookup_inductive rectype in + let nparams = mib.mind_nparams in + let getargs l = List.skipn nparams (snd (decompose_app l)) in + let rargs = getargs rhs + and largs = getargs lhs in + List.fold_right2 + (solveArg eqonleft op) largs rargs + (tclTHEN (choose_eq eqonleft) intros_reflexivity) + end + end + begin function (e, info) -> match e with + | PatternMatchingFailure -> Proofview.tclZERO (UserError ("",Pp.str"Unexpected conclusion!")) + | e -> Proofview.tclZERO ~info e + end + +(* The tactic Decide Equality *) + +let hd_app c = match kind_of_term c with + | App (h,_) -> h + | _ -> c + +let decideGralEquality = + Proofview.tclORELSE + begin + Proofview.Goal.enter begin fun gl -> + let concl = pf_nf_concl gl in + match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> + let headtyp = hd_app (pf_compute gl typ) in + begin match kind_of_term headtyp with + | Ind (mi,_) -> Proofview.tclUNIT mi + | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") + end >>= fun rectype -> + (tclTHEN + (mkBranches c1 c2) + (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) + end + end + begin function (e, info) -> match e with + | PatternMatchingFailure -> + Proofview.tclZERO (UserError ("", Pp.str"The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}.")) + | e -> Proofview.tclZERO ~info e + end + +let decideEqualityGoal = tclTHEN intros decideGralEquality + +let decideEquality rectype = + Proofview.Goal.enter begin fun gl -> + let decide = mkGenDecideEqGoal rectype gl in + (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) + end + + +(* The tactic Compare *) + +let compare c1 c2 = + Proofview.Goal.enter begin fun gl -> + let rectype = pf_type_of gl c1 in + let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in + (tclTHENS (cut decide) + [(tclTHEN intro + (tclTHEN (onLastHyp simplest_case) clear_last)); + decideEquality rectype]) + end diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4 deleted file mode 100644 index 4a11d586..00000000 --- a/tactics/eqdecide.ml4 +++ /dev/null @@ -1,188 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (clear [destVar c]))) - -let choose_eq eqonleft = - if eqonleft then h_simplest_left else h_simplest_right -let choose_noteq eqonleft = - if eqonleft then h_simplest_right else h_simplest_left - -let mkBranches c1 c2 = - tclTHENSEQ - [generalize [c2]; - h_simplest_elim c1; - intros; - onLastHyp h_simplest_case; - clear_last; - intros] - -let solveNoteqBranch side = - tclTHEN (choose_noteq side) - (tclTHEN introf - (onLastHypId (fun id -> Extratactics.h_discrHyp id))) - -let h_solveNoteqBranch side = - Refiner.abstract_extended_tactic "solveNoteqBranch" [] - (solveNoteqBranch side) - -(* Constructs the type {c1=c2}+{~c1=c2} *) - -let mkDecideEqGoal eqonleft op rectype c1 c2 g = - let equality = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in - let disequality = mkApp(build_coq_not (), [|equality|]) in - if eqonleft then mkApp(op, [|equality; disequality |]) - else mkApp(op, [|disequality; equality |]) - - -(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) - -let mkGenDecideEqGoal rectype g = - let hypnames = pf_ids_of_hyps g in - let xname = next_ident_away (id_of_string "x") hypnames - and yname = next_ident_away (id_of_string "y") hypnames in - (mkNamedProd xname rectype - (mkNamedProd yname rectype - (mkDecideEqGoal true (build_coq_sumbool ()) - rectype (mkVar xname) (mkVar yname) g))) - -let eqCase tac = - (tclTHEN intro - (tclTHEN (onLastHyp Equality.rewriteLR) - (tclTHEN clear_last - tac))) - -let diseqCase eqonleft = - let diseq = id_of_string "diseq" in - let absurd = id_of_string "absurd" in - (tclTHEN (intro_using diseq) - (tclTHEN (choose_noteq eqonleft) - (tclTHEN red_in_concl - (tclTHEN (intro_using absurd) - (tclTHEN (h_simplest_apply (mkVar diseq)) - (tclTHEN (Extratactics.h_injHyp absurd) - (full_trivial []))))))) - -let solveArg eqonleft op a1 a2 tac g = - let rectype = pf_type_of g a1 in - let decide = mkDecideEqGoal eqonleft op rectype a1 a2 g in - let subtacs = - if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto] - else [diseqCase eqonleft;eqCase tac;default_auto] in - (tclTHENS (h_elim_type decide) subtacs) g - -let solveEqBranch rectype g = - try - let (eqonleft,op,lhs,rhs,_) = match_eqdec (pf_concl g) in - let (mib,mip) = Global.lookup_inductive rectype in - let nparams = mib.mind_nparams in - let getargs l = list_skipn nparams (snd (decompose_app l)) in - let rargs = getargs rhs - and largs = getargs lhs in - List.fold_right2 - (solveArg eqonleft op) largs rargs - (tclTHEN (choose_eq eqonleft) h_reflexivity) g - with PatternMatchingFailure -> error "Unexpected conclusion!" - -(* The tactic Decide Equality *) - -let hd_app c = match kind_of_term c with - | App (h,_) -> h - | _ -> c - -let decideGralEquality g = - try - let eqonleft,_,c1,c2,typ = match_eqdec (pf_concl g) in - let headtyp = hd_app (pf_compute g typ) in - let rectype = - match kind_of_term headtyp with - | Ind mi -> mi - | _ -> error"This decision procedure only works for inductive objects." - in - (tclTHEN - (mkBranches c1 c2) - (tclORELSE (h_solveNoteqBranch eqonleft) (solveEqBranch rectype))) - g - with PatternMatchingFailure -> - error "The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}." - -let decideEqualityGoal = tclTHEN intros decideGralEquality - -let decideEquality rectype g = - let decide = mkGenDecideEqGoal rectype g in - (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) g - - -(* The tactic Compare *) - -let compare c1 c2 g = - let rectype = pf_type_of g c1 in - let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in - (tclTHENS (cut decide) - [(tclTHEN intro - (tclTHEN (onLastHyp simplest_case) - clear_last)); - decideEquality (pf_type_of g c1)]) g - - -(* User syntax *) - -TACTIC EXTEND decide_equality -| [ "decide" "equality" ] -> [ decideEqualityGoal ] -END - -TACTIC EXTEND compare -| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] -END diff --git a/tactics/eqdecide.mli b/tactics/eqdecide.mli new file mode 100644 index 00000000..864160f6 --- /dev/null +++ b/tactics/eqdecide.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Constr.t -> unit Proofview.tactic diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 5a8d537e..8643fe10 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* hid | InType -> xid let fresh env id = next_global_ident_away id [] +let with_context_set ctx (b, ctx') = + (b, Univ.ContextSet.union ctx ctx') let build_dependent_inductive ind (mib,mip) = - let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in applist - (mkInd ind, - extended_rel_list mip.mind_nrealargs_ctxt mib.mind_params_ctxt + (mkIndU ind, + extended_rel_list mip.mind_nrealdecls mib.mind_params_ctxt @ extended_rel_list 0 realargs) let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s @@ -73,12 +78,13 @@ let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s let my_it_mkLambda_or_LetIn_name s c = it_mkLambda_or_LetIn_name (Global.env()) c s -let get_coq_eq () = +let get_coq_eq ctx = try - let eq = Libnames.destIndRef Coqlib.glob_eq in - let _ = Global.lookup_inductive eq in + let eq = Globnames.destIndRef Coqlib.glob_eq in (* Do not force the lazy if they are not defined *) - mkInd eq, Coqlib.build_coq_eq_refl () + let eq, ctx = with_context_set ctx + (Universes.fresh_inductive_instance (Global.env ()) eq) in + mkIndU eq, mkConstructUi (eq,1), ctx with Not_found -> error "eq not found." @@ -91,27 +97,30 @@ let get_coq_eq () = (* in which case, a symmetry lemma is definable *) (**********************************************************************) -let get_sym_eq_data env ind = +let get_sym_eq_data env (ind,u) = let (mib,mip as specif) = lookup_mind_specif env ind in - if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then + if not (Int.equal (Array.length mib.mind_packets) 1) || + not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; - let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in - if List.exists (fun (_,b,_) -> b <> None) realsign then + let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in + let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in + if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported."; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in - if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then + if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; (* This can be relaxed... *) - let params,constrargs = list_chop mib.mind_nparams constrargs in + let params,constrargs = List.chop mib.mind_nparams constrargs in if mip.mind_nrealargs > mib.mind_nparams then error "Constructors arguments must repeat the parameters."; - let _,params2 = list_chop (mib.mind_nparams-mip.mind_nrealargs) params in + let _,params2 = List.chop (mib.mind_nparams-mip.mind_nrealargs) params in + let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in let paramsctxt1,_ = - list_chop (mib.mind_nparams-mip.mind_nrealargs) mib.mind_params_ctxt in - if not (list_equal eq_constr params2 constrargs) then + List.chop (mib.mind_nparams-mip.mind_nrealargs) paramsctxt in + if not (List.equal eq_constr params2 constrargs) then error "Constructors arguments must repeat the parameters."; (* nrealargs_ctxt and nrealargs are the same here *) - (specif,mip.mind_nrealargs,realsign,mib.mind_params_ctxt,paramsctxt1) + (specif,mip.mind_nrealargs,realsign,paramsctxt,paramsctxt1) (**********************************************************************) (* Check if an inductive type [ind] has the form *) @@ -123,19 +132,23 @@ let get_sym_eq_data env ind = (* such that symmetry is a priori definable *) (**********************************************************************) -let get_non_sym_eq_data env ind = +let get_non_sym_eq_data env (ind,u) = let (mib,mip as specif) = lookup_mind_specif env ind in - if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then + if not (Int.equal (Array.length mib.mind_packets) 1) || + not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; - let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in - if List.exists (fun (_,b,_) -> b <> None) realsign then + let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in + let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in + if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported"; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in - if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then + if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; - let _,constrargs = list_chop mib.mind_nparams constrargs in - (specif,constrargs,realsign,mip.mind_nrealargs) + let _,constrargs = List.chop mib.mind_nparams constrargs in + let constrargs = List.map (Vars.subst_instance_constr u) constrargs in + let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in + (specif,constrargs,realsign,paramsctxt,mip.mind_nrealargs) (**********************************************************************) (* Build the symmetry lemma associated to an inductive type *) @@ -152,30 +165,35 @@ let get_non_sym_eq_data env ind = (**********************************************************************) let build_sym_scheme env ind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in + get_sym_eq_data env indu in let cstr n = - mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (mkInd ind,Array.concat + (mkApp (mkIndU indu,Array.concat [extended_rel_vect (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs])), mkRel 1 (* varH *), [|cstr (nrealargs+1)|])))) + in c, Evd.evar_universe_context_of ctx let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" - (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind) + (fun ind -> + let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in + (c, ctx), Declareops.no_seff) (**********************************************************************) (* Build the involutivity of symmetry for an inductive type *) @@ -193,49 +211,59 @@ let sym_scheme_kind = (* *) (**********************************************************************) +let const_of_scheme kind env ind ctx = + let sym_scheme, eff = (find_scheme kind ind) in + let sym, ctx = with_context_set ctx + (Universes.fresh_constant_instance (Global.env()) sym_scheme) in + mkConstU sym, ctx, eff + let build_sym_involutive_scheme env ind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in - let sym = mkConst (find_scheme sym_scheme_kind ind) in - let (eq,eqrefl) = get_coq_eq () in - let cstr n = mkApp (mkConstruct(ind,1),extended_rel_vect n paramsctxt) in + get_sym_eq_data env indu in + let eq,eqrefl,ctx = get_coq_eq ctx in + let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let cstr n = mkApp (mkConstructUi (indu,1),extended_rel_vect n paramsctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let applied_ind = build_dependent_inductive ind specif in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_C = mkApp - (mkInd ind, Array.append + (mkIndU indu, Array.append (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt) (rel_vect (nrealargs+1) nrealargs)) in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in - (my_it_mkLambda_or_LetIn paramsctxt - (my_it_mkLambda_or_LetIn_name realsign_ind - (mkCase (ci, - my_it_mkLambda_or_LetIn_name - (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (eq,[| - mkApp - (mkInd ind, Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect (2*nrealargs+2) nrealargs; - rel_vect 1 nrealargs]); - mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect 1 nrealargs; - rel_vect (2*nrealargs+2) nrealargs; - [|mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; - rel_vect (2*nrealargs+2) nrealargs; - rel_vect 1 nrealargs; - [|mkRel 1|]])|]]); - mkRel 1|])), - mkRel 1 (* varH *), - [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) + let c = + (my_it_mkLambda_or_LetIn paramsctxt + (my_it_mkLambda_or_LetIn_name realsign_ind + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkApp (eq,[| + mkApp + (mkIndU indu, Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs]); + mkApp (sym,Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect 1 nrealargs; + rel_vect (2*nrealargs+2) nrealargs; + [|mkApp (sym,Array.concat + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs; + [|mkRel 1|]])|]]); + mkRel 1|])), + mkRel 1 (* varH *), + [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) + in (c, Evd.evar_universe_context_of ctx), eff let sym_involutive_scheme_kind = declare_individual_scheme_object "_sym_involutive" - (fun ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) + (fun ind -> + build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) (**********************************************************************) (* Build the left-to-right rewriting lemma for conclusion associated *) @@ -298,26 +326,27 @@ let sym_involutive_scheme_kind = (**********************************************************************) let build_l2r_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in - let sym = mkConst (find_scheme sym_scheme_kind ind) in - let sym_involutive = mkConst (find_scheme sym_involutive_scheme_kind ind) in - let (eq,eqrefl) = get_coq_eq () in + get_sym_eq_data env indu in + let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let sym_involutive, ctx, eff' = const_of_scheme sym_involutive_scheme_kind env ind ctx in + let eq,eqrefl,ctx = get_coq_eq ctx in let cstr n p = - mkApp (mkConstruct(ind,1), + mkApp (mkConstructUi(indu,1), Array.concat [extended_rel_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let varHC = fresh env (id_of_string "HC") in - let varP = fresh env (id_of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let varHC = fresh env (Id.of_string "HC") in + let varP = fresh env (Id.of_string "P") in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs) paramsctxt1; rel_vect 0 nrealargs; rel_vect nrealargs nrealargs]) in let applied_ind_G = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs+3) paramsctxt1; rel_vect (nrealargs+3) nrealargs; rel_vect 0 nrealargs]) in @@ -336,9 +365,11 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect (nrealargs+4) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]]) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in - let cieq = make_case_info (Global.env()) (destInd eq) RegularStyle in + let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append (extended_rel_vect 1 realsign) (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in @@ -363,6 +394,7 @@ let build_l2r_rew_scheme dep env ind kind = my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, applied_sym_C 3, [|mkVar varHC|]) in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varP @@ -380,6 +412,7 @@ let build_l2r_rew_scheme dep env ind kind = [|main_body|]) else main_body)))))) + in (c, Evd.evar_universe_context_of ctx), Declareops.union_side_effects eff' eff (**********************************************************************) (* Build the left-to-right rewriting lemma for hypotheses associated *) @@ -408,23 +441,24 @@ let build_l2r_rew_scheme dep env ind kind = (**********************************************************************) let build_l2r_forward_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = - get_sym_eq_data env ind in + get_sym_eq_data env indu in let cstr n p = - mkApp (mkConstruct(ind,1), + mkApp (mkConstructUi(indu,1), Array.concat [extended_rel_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let varHC = fresh env (id_of_string "HC") in - let varP = fresh env (id_of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let varHC = fresh env (Id.of_string "HC") in + let varP = fresh env (Id.of_string "P") in + let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (4*nrealargs+2) paramsctxt1; rel_vect 0 nrealargs; rel_vect (nrealargs+1) nrealargs]) in let applied_ind_P' = - mkApp (mkInd ind, Array.concat + mkApp (mkIndU indu, Array.concat [extended_rel_vect (3*nrealargs+1) paramsctxt1; rel_vect 0 nrealargs; rel_vect (2*nrealargs+1) nrealargs]) in @@ -433,7 +467,9 @@ let build_l2r_forward_rew_scheme dep env ind kind = name_context env ((Name varH,None,applied_ind)::realsign) in let realsign_ind_P n aP = name_context env ((Name varH,None,aP)::realsign_P n) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append @@ -447,6 +483,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = let applied_PG = mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs) (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in + let c = (my_it_mkLambda_or_LetIn mib.mind_params_ctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varH applied_ind @@ -463,6 +500,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) (mkNamedLambda varHC applied_PC' (mkVar varHC))|]))))) + in c, Evd.evar_universe_context_of ctx (**********************************************************************) (* Build the right-to-left rewriting lemma for hypotheses associated *) @@ -494,19 +532,22 @@ let build_l2r_forward_rew_scheme dep env ind kind = (* statement but no need for symmetry of the equality. *) (**********************************************************************) -let build_r2l_forward_rew_scheme dep env ind kind = - let ((mib,mip as specif),constrargs,realsign,nrealargs) = - get_non_sym_eq_data env ind in +let build_r2l_forward_rew_scheme dep env ind kind = + let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in + let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) = + get_non_sym_eq_data env indu in let cstr n = - mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in let constrargs_cstr = constrargs@[cstr 0] in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in - let varHC = fresh env (id_of_string "HC") in - let varP = fresh env (id_of_string "P") in - let applied_ind = build_dependent_inductive ind specif in + let varHC = fresh env (Id.of_string "HC") in + let varP = fresh env (Id.of_string "P") in + let applied_ind = build_dependent_inductive indu specif in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in - let s = mkSort (new_sort_in_family kind) in + let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let ctx = Univ.ContextSet.union ctx ctx' in + let s = mkSort s in let ci = make_case_info (Global.env()) ind RegularStyle in let applied_PC = applist (mkVar varP,if dep then constrargs_cstr else constrargs) in @@ -514,7 +555,8 @@ let build_r2l_forward_rew_scheme dep env ind kind = mkApp (mkVar varP, if dep then extended_rel_vect 0 realsign_ind else extended_rel_vect 1 realsign) in - (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + let c = + (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkNamedLambda varP (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1) @@ -531,6 +573,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = lift (nrealargs+3) applied_PC, mkRel 1)|]), [|mkVar varHC|])))))) + in c, Evd.evar_universe_context_of ctx (**********************************************************************) (* This function "repairs" the non-dependent r2l forward rewriting *) @@ -548,11 +591,12 @@ let build_r2l_forward_rew_scheme dep env ind kind = (* *) (**********************************************************************) -let fix_r2l_forward_rew_scheme c = +let fix_r2l_forward_rew_scheme (c, ctx') = let t = Retyping.get_type_of (Global.env()) Evd.empty c in let ctx,_ = decompose_prod_assum t in match ctx with | hp :: p :: ind :: indargs -> + let c' = my_it_mkLambda_or_LetIn indargs (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 1) p) (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 2) hp) @@ -560,7 +604,8 @@ let fix_r2l_forward_rew_scheme c = (Reductionops.whd_beta Evd.empty (applist (c, extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) - | _ -> anomaly "Ill-formed non-dependent left-to-right rewriting scheme" + in c', ctx' + | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme") (**********************************************************************) (* Build the right-to-left rewriting lemma for conclusion associated *) @@ -582,9 +627,16 @@ let fix_r2l_forward_rew_scheme c = (* (H:I q1..qm a1..an), *) (* P b1..bn C -> P a1..an H *) (**********************************************************************) - + let build_r2l_rew_scheme dep env ind k = - build_case_analysis_scheme env Evd.empty ind dep k + let sigma, indu = Evd.fresh_inductive_instance env (Evd.from_env env) ind in + let sigma', c = build_case_analysis_scheme env sigma indu dep k in + c, Evd.evar_universe_context sigma' + +let build_l2r_rew_scheme = build_l2r_rew_scheme +let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme +let build_r2l_rew_scheme = build_r2l_rew_scheme +let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme (**********************************************************************) (* Register the rewriting schemes *) @@ -608,7 +660,7 @@ let rew_l2r_dep_scheme_kind = (**********************************************************************) let rew_r2l_dep_scheme_kind = declare_individual_scheme_object "_rew_dep" - (fun ind -> build_r2l_rew_scheme true (Global.env()) ind InType) + (fun ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) (**********************************************************************) (* Dependent rewrite from right-to-left in hypotheses *) @@ -618,7 +670,7 @@ let rew_r2l_dep_scheme_kind = (**********************************************************************) let rew_r2l_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_dep" - (fun ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType) + (fun ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) (**********************************************************************) (* Dependent rewrite from left-to-right in hypotheses *) @@ -628,7 +680,7 @@ let rew_r2l_forward_dep_scheme_kind = (**********************************************************************) let rew_l2r_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_r_dep" - (fun ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType) + (fun ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) (**********************************************************************) (* Non-dependent rewrite from either left-to-right in conclusion or *) @@ -642,7 +694,7 @@ let rew_l2r_forward_dep_scheme_kind = let rew_l2r_scheme_kind = declare_individual_scheme_object "_rew_r" (fun ind -> fix_r2l_forward_rew_scheme - (build_r2l_forward_rew_scheme false (Global.env()) ind InType)) + (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Declareops.no_seff) (**********************************************************************) (* Non-dependent rewrite from either right-to-left in conclusion or *) @@ -652,7 +704,7 @@ let rew_l2r_scheme_kind = (**********************************************************************) let rew_r2l_scheme_kind = declare_individual_scheme_object "_rew" - (fun ind -> build_r2l_rew_scheme false (Global.env()) ind InType) + (fun ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Declareops.no_seff) (* End of rewriting schemes *) @@ -671,35 +723,41 @@ let rew_r2l_scheme_kind = (* TODO: extend it to types with more than one index *) -let build_congr env (eq,refl) ind = +let build_congr env (eq,refl,ctx) ind = + let (ind,u as indu), ctx = with_context_set ctx + (Universes.fresh_inductive_instance env ind) in let (mib,mip) = lookup_mind_specif env ind in - if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then + if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; - if mip.mind_nrealargs <> 1 then + if not (Int.equal mip.mind_nrealargs 1) then error "Expect an inductive type with one predicate parameter."; let i = 1 in - let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in - if List.exists (fun (_,b,_) -> b <> None) realsign then + let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in + let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in + let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in + if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then error "Inductive equalities with local definitions in arity not supported."; - let env_with_arity = push_rel_context mip.mind_arity_ctxt env in + let env_with_arity = push_rel_context arityctxt env in let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in - if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then + if Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt) then error "Constructor must have no arguments"; let b = List.nth constrargs (i + mib.mind_nparams - 1) in - let varB = fresh env (id_of_string "B") in - let varH = fresh env (id_of_string "H") in - let varf = fresh env (id_of_string "f") in + let varB = fresh env (Id.of_string "B") in + let varH = fresh env (Id.of_string "H") in + let varf = fresh env (Id.of_string "f") in let ci = make_case_info (Global.env()) ind RegularStyle in - my_it_mkLambda_or_LetIn mib.mind_params_ctxt - (mkNamedLambda varB (new_Type ()) + let uni, ctx = Universes.extend_context (Universes.new_global_univ ()) ctx in + let c = + my_it_mkLambda_or_LetIn paramsctxt + (mkNamedLambda varB (mkSort (Type uni)) (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB)) (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign) (mkNamedLambda varH (applist - (mkInd ind, - extended_rel_list (mip.mind_nrealargs+2) mib.mind_params_ctxt @ + (mkIndU indu, + extended_rel_list (mip.mind_nrealargs+2) paramsctxt @ extended_rel_list 0 realsign)) (mkCase (ci, my_it_mkLambda_or_LetIn_name @@ -707,20 +765,21 @@ let build_congr env (eq,refl) ind = (mkLambda (Anonymous, applist - (mkInd ind, - extended_rel_list (2*mip.mind_nrealargs_ctxt+3) - mib.mind_params_ctxt + (mkIndU indu, + extended_rel_list (2*mip.mind_nrealdecls+3) + paramsctxt @ extended_rel_list 0 realsign), mkApp (eq, [|mkVar varB; - mkApp (mkVar varf, [|lift (2*mip.mind_nrealargs_ctxt+4) b|]); + mkApp (mkVar varf, [|lift (2*mip.mind_nrealdecls+4) b|]); mkApp (mkVar varf, [|mkRel (mip.mind_nrealargs - i + 2)|])|]))), mkVar varH, [|mkApp (refl, [|mkVar varB; mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|])))))) + in c, Evd.evar_universe_context_of ctx let congr_scheme_kind = declare_individual_scheme_object "_congr" (fun ind -> (* May fail if equality is not defined *) - build_congr (Global.env()) (get_coq_eq ()) ind) + build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index 2f973e6d..6bb84808 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* 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 +val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> + constr Evd.in_evar_universe_context +val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> + constr Evd.in_evar_universe_context * Declareops.side_effects val build_r2l_forward_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr + bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context val build_l2r_forward_rew_scheme : - bool -> env -> inductive -> sorts_family -> constr + bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context (** Builds a symmetry scheme for a symmetrical equality type *) -val build_sym_scheme : env -> inductive -> constr +val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context val sym_scheme_kind : individual scheme_kind -val build_sym_involutive_scheme : env -> inductive -> constr +val build_sym_involutive_scheme : env -> inductive -> + constr Evd.in_evar_universe_context * Declareops.side_effects val sym_involutive_scheme_kind : individual scheme_kind (** Builds a congruence scheme for an equality type *) val congr_scheme_kind : individual scheme_kind -val build_congr : env -> constr * constr -> inductive -> constr +val build_congr : env -> constr * constr * Univ.universe_context_set -> inductive -> + constr Evd.in_evar_universe_context diff --git a/tactics/equality.ml b/tactics/equality.ml index 184f98ca..c130fa15 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1,49 +1,47 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* !discriminate_introduction); optwrite = (:=) discriminate_introduction } +let injection_pattern_l2r_order = ref true + +let use_injection_pattern_l2r_order () = + !injection_pattern_l2r_order + && Flags.version_strictly_greater Flags.V8_4 + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "injection left-to-right pattern order"; + optkey = ["Injection";"L2R";"Pattern";"Order"]; + optread = (fun () -> !injection_pattern_l2r_order) ; + optwrite = (fun b -> injection_pattern_l2r_order := b) } + (* Rewriting tactics *) +let clear ids = Proofview.V82.tactic (clear ids) + +let tclNOTSAMEGOAL tac = + Proofview.V82.tactic (Tacticals.tclNOTSAMEGOAL (Proofview.V82.of_tactic tac)) + type dep_proof_flag = bool (* true = support rewriting dependent proofs *) type freeze_evars_flag = bool (* true = don't instantiate existing evars *) @@ -82,35 +100,44 @@ type conditions = -- Eduardo (19/8/97) *) +let rewrite_core_unif_flags = { + modulo_conv_on_closed_terms = None; + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + modulo_delta = empty_transparent_state; + modulo_delta_types = empty_transparent_state; + check_applied_meta_types = true; + use_pattern_unification = true; + use_meta_bound_pattern_unification = true; + frozen_evars = Evar.Set.empty; + restrict_conv_on_strict_subterms = false; + modulo_betaiota = false; + modulo_eta = true; +} + 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 = empty_transparent_state; - Unification.modulo_delta_in_merge = None; - 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 = false; - Unification.modulo_eta = true; - Unification.allow_K_in_toplevel_higher_order_unification = false + core_unify_flags = rewrite_core_unif_flags; + merge_unify_flags = rewrite_core_unif_flags; + subterm_unify_flags = rewrite_core_unif_flags; + allow_K_in_toplevel_higher_order_unification = false; (* allow_K does not matter in practice because calls w_typed_unify *) + resolve_evars = true } 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 newevars = Evd.evars_of_term (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 } + if Evar.Set.mem evk newevars then evars + else Evar.Set.add evk evars) + sigma Evar.Set.empty in + {flags with + core_unify_flags = {flags.core_unify_flags with frozen_evars = evars}; + merge_unify_flags = {flags.merge_unify_flags with frozen_evars = evars}; + subterm_unify_flags = {flags.subterm_unify_flags with frozen_evars = evars}} let make_flags frzevars sigma flags clause = if frzevars then freeze_initial_evars sigma flags clause else flags @@ -118,89 +145,91 @@ let make_flags frzevars sigma flags clause = let side_tac tac sidetac = match sidetac with | None -> tac - | Some sidetac -> tclTHENSFIRSTn tac [|tclIDTAC|] sidetac - -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 - | [c1;c2] -> [],(c1, c2) - | x::y::z -> - let l,res = split_last_two (y::z) in x::l, res - | _ -> error "The term provided is not an applied relation." in - let others,(c1,c2) = split_last_two args in + | Some sidetac -> tclTHENSFIRSTn tac [|Proofview.tclUNIT ()|] sidetac + +let instantiate_lemma_all frzevars gl c ty l l2r concl = + let env = Proofview.Goal.env gl in + let eqclause = pf_apply Clenv.make_clenv_binding gl (c,ty) l in + let (equiv, args) = decompose_appvect (Clenv.clenv_type eqclause) in + let arglen = Array.length args in + let () = if arglen < 2 then error "The term provided is not an applied relation." in + let c1 = args.(arglen - 2) in + let c2 = args.(arglen - 1) in let try_occ (evd', c') = - clenv_pose_dependent_evars true {eqclause with evd = evd'} + Clenvtac.clenv_pose_dependent_evars true {eqclause with evd = evd'} in - let flags = make_flags frzevars sigma rewrite_unif_flags eqclause in + let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_unif_flags eqclause in let occs = - Unification.w_unify_to_subterm_all ~flags env eqclause.evd + 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 = - let gl = { gl with sigma = sigma } in +let instantiate_lemma gl c ty l l2r concl = let ct = pf_type_of gl c in let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in - let eqclause = Clenv.make_clenv_binding gl (c,t) l in + let eqclause = pf_apply Clenv.make_clenv_binding gl (c,t) l in [eqclause] -let rewrite_conv_closed_unif_flags = { - Unification.modulo_conv_on_closed_terms = Some full_transparent_state; +let rewrite_conv_closed_core_unif_flags = { + 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; + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; (* 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.modulo_delta_in_merge = None; - Unification.check_applied_meta_types = true; - Unification.resolve_evars = false; - Unification.use_pattern_unification = true; + modulo_delta = empty_transparent_state; + modulo_delta_types = full_transparent_state; + check_applied_meta_types = true; + 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; + use_meta_bound_pattern_unification = true; - Unification.frozen_evars = ExistentialSet.empty; + frozen_evars = Evar.Set.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 + restrict_conv_on_strict_subterms = false; + modulo_betaiota = false; + modulo_eta = true; } -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_conv_closed_unif_flags = { + core_unify_flags = rewrite_conv_closed_core_unif_flags; + merge_unify_flags = rewrite_conv_closed_core_unif_flags; + subterm_unify_flags = rewrite_conv_closed_core_unif_flags; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = false +} -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 +let rewrite_elim with_evars frzevars cls c e = + Proofview.Goal.enter begin fun gl -> + let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_conv_closed_unif_flags c in + general_elim_clause with_evars flags cls c e + end (* Ad hoc asymmetric general_elim_clause *) 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 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,evd,Pretype_errors.NoOccurrenceFound (c', cls))) - -let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl = + let open Pretype_errors in + Proofview.tclORELSE + begin 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 frzevars cls rew elim) + | Some _ -> rewrite_elim with_evars frzevars cls rew elim + end + begin function (e, info) -> match e with + | PretypeError (env, evd, NoOccurrenceFound (c', _)) -> + Proofview.tclZERO (PretypeError (env, evd, NoOccurrenceFound (c', cls))) + | e -> Proofview.tclZERO ~info e + end + +let general_elim_clause with_evars frzevars tac cls c t l l2r elim = let all, firstonly, tac = match tac with | None -> false, false, None @@ -208,20 +237,26 @@ let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl = | Some (tac, FirstSolved) -> true, true, Some (tclCOMPLETE tac) | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac) in - let cs = - (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 frzevars cls c elim)) tac + (Proofview.Unsafe.tclEVARS c.evd) + (general_elim_clause with_evars frzevars cls c elim)) + tac in - if firstonly then - tclFIRST (List.map try_clause cs) gl - else tclMAP try_clause cs gl + Proofview.Goal.enter begin fun gl -> + let instantiate_lemma concl = + if not all then instantiate_lemma gl c t l l2r concl + else instantiate_lemma_all frzevars gl c t l l2r concl + in + let typ = match cls with + | None -> pf_nf_concl gl + | Some id -> pf_get_hyp_typ id (Proofview.Goal.assume gl) + in + let cs = instantiate_lemma typ in + if firstonly then tclFIRST (List.map try_clause cs) + else tclMAP try_clause cs + end (* The next function decides in particular whether to try a regular rewrite or a generalized rewrite. @@ -230,11 +265,7 @@ let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl = If occurrences are set, use general rewrite. *) -let general_rewrite_clause = ref (fun _ -> assert false) -let register_general_rewrite_clause = (:=) general_rewrite_clause - -let is_applied_rewrite_relation = ref (fun _ _ _ _ -> None) -let register_is_applied_rewrite_relation = (:=) is_applied_rewrite_relation +let (forward_general_setoid_rewrite_clause, general_setoid_rewrite_clause) = Hook.make () (* Do we have a JMeq instance on twice the same domains ? *) @@ -242,46 +273,51 @@ let jmeq_same_dom gl = function | None -> true (* already checked in Hipattern.find_eq_data_decompose *) | Some t -> let rels, t = decompose_prod_assum t in - let env = Environ.push_rel_context rels (pf_env gl) in + let env = Environ.push_rel_context rels (Proofview.Goal.env gl) in match decompose_app t with - | _, [dom1; _; dom2;_] -> is_conv env (project gl) dom1 dom2 + | _, [dom1; _; dom2;_] -> is_conv env (Proofview.Goal.sigma gl) dom1 dom2 | _ -> false (* find_elim determines which elimination principle is necessary to eliminate lbeq on sort_of_gl. *) let find_elim hdcncl lft2rgt dep cls ot gl = - let inccl = not (Option.has_some cls) in - let hdcncl_is u = eq_constr hdcncl (constr_of_reference u) in - if (hdcncl_is (Coqlib.glob_eq) || - hdcncl_is (Coqlib.glob_jmeq) && jmeq_same_dom gl ot) - && not dep - || Flags.version_less_or_equal Flags.V8_2 + let inccl = Option.is_empty cls in + if (is_global Coqlib.glob_eq hdcncl || + (is_global Coqlib.glob_jmeq hdcncl && + jmeq_same_dom gl ot)) && not dep + || Flags.version_less_or_equal Flags.V8_2 then - match kind_of_term hdcncl with - | Ind ind_sp -> + let c = + match kind_of_term hdcncl with + | Ind (ind_sp,u) -> let pr1 = lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) - in - if lft2rgt = Some (cls=None) - then - let c1 = destConst pr1 in + in + begin match lft2rgt, cls with + | Some true, None + | Some false, Some _ -> + let c1 = destConstRef pr1 in let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in - let l' = label_of_id (add_suffix (id_of_label l) "_r") in + let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in begin try let _ = Global.lookup_constant c1' in - mkConst c1' + c1' with Not_found -> - let rwr_thm = string_of_label l' in + let rwr_thm = Label.to_string l' in error ("Cannot find rewrite principle "^rwr_thm^".") end - else pr1 + | _ -> destConstRef pr1 + end | _ -> (* cannot occur since we checked that we are in presence of Logic.eq or Jmeq just before *) assert false + in + let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + sigma, elim, Declareops.no_seff else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) @@ -296,31 +332,39 @@ let find_elim hdcncl lft2rgt dep cls ot gl = | true, _, false -> rew_r2l_forward_dep_scheme_kind in match kind_of_term hdcncl with - | Ind ind -> mkConst (find_scheme scheme_name ind) + | Ind (ind,u) -> + let c, eff = find_scheme scheme_name ind in + (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) + let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + sigma, elim, eff | _ -> assert false -let type_of_clause gl = function - | None -> pf_concl gl - | Some id -> pf_get_hyp_typ gl id +let type_of_clause cls gl = match cls with + | None -> Proofview.Goal.concl gl + | Some id -> pf_get_hyp_typ id gl -let leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars frzevars dep_proof_ok gl hdcncl = +let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = + Proofview.Goal.nf_enter begin fun gl -> 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 (Some t) gl in - 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 + let type_of_cls = type_of_clause cls gl in + let dep = dep_proof_ok && dep_fun c type_of_cls in + let (sigma,elim,effs) = find_elim hdcncl lft2rgt dep cls (Some t) gl in + Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS effs <*> + general_elim_clause with_evars frzevars tac cls c t l + (match lft2rgt with None -> false | Some b -> b) + {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} + end let adjust_rewriting_direction args lft2rgt = - if List.length args = 1 then begin + match args with + | [_] -> (* equality to a constant, like in eq_true *) (* more natural to see -> as the rewriting to the constant *) if not lft2rgt then error "Rewriting non-symmetric equality not allowed from right-to-left."; None - end - else + | _ -> (* other equality *) Some lft2rgt @@ -329,34 +373,39 @@ 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 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) + ((c,l) : constr with_bindings) with_evars = + if occs != AllOccurrences then ( + rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac) else - let env = pf_env gl in - let sigma = project gl in + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in match match_with_equality_type t with | 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 frzevars dep_proof_ok gl hdcncl + leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels) + l with_evars frzevars dep_proof_ok hdcncl | None -> - try - rewrite_side_tac (!general_rewrite_clause cls - lft2rgt occs (c,l) ~new_goals:[]) tac gl - with e when Errors.noncritical e -> - (* Try to see if there's an equality hidden *) - let env' = push_rel_context rels env in - let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) - match match_with_equality_type t' with - | Some (hdcncl,args) -> + Proofview.tclORELSE + begin + rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls + lft2rgt occs (c,l) ~new_goals:[]) tac + end + begin function + | (e, info) -> + let env' = push_rel_context rels env in + let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) + match match_with_equality_type t' with + | 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 frzevars dep_proof_ok gl hdcncl - | None -> raise e - (* error "The provided term does not end with an equality or a declared rewrite relation." *) + leibniz_rewrite_ebindings_clause cls lft2rgt tac c + (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok hdcncl + | None -> Proofview.tclZERO ~info e + (* error "The provided term does not end with an equality or a declared rewrite relation." *) + end + end let general_rewrite_ebindings = general_rewrite_ebindings_clause None @@ -380,8 +429,8 @@ 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 +let general_rewrite_clause l2r with_evars ?tac c cl = + let occs_of = occurrences_map (List.fold_left (fun acc -> function ArgArg x -> x :: acc | ArgVar _ -> acc) []) @@ -391,108 +440,163 @@ let general_multi_rewrite l2r with_evars ?tac c cl = (* If a precise list of locations is given, success is mandatory for each of these locations. *) let rec do_hyps = function - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | ((occs,id),_) :: l -> tclTHENFIRST (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 + if cl.concl_occs == NoOccurrences then do_hyps l else tclTHENFIRST - (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) - (do_hyps l) + (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 syntax "* |-", we fail iff all the different rewrites fail *) let rec do_hyps_atleastonce = function - | [] -> (fun gl -> error "Nothing to rewrite.") + | [] -> Proofview.tclZERO (Errors.UserError ("",Pp.str"Nothing to rewrite.")) | id :: l -> tclIFTHENTRYELSEMUST - (general_rewrite_ebindings_in l2r all_occurrences false true ?tac id c with_evars) + (general_rewrite_ebindings_in l2r AllOccurrences false true ?tac id c with_evars) (do_hyps_atleastonce l) in - let do_hyps gl = + let do_hyps = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) - let ids = + let ids gl = let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in - Idset.fold (fun id l -> list_remove id l) ids_in_c (pf_ids_of_hyps gl) - in do_hyps_atleastonce ids gl + let ids_of_hyps = pf_ids_of_hyps gl in + Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps + in + Proofview.Goal.enter begin fun gl -> + do_hyps_atleastonce (ids gl) + end in - if cl.concl_occs = no_occurrences_expr then do_hyps else + if cl.concl_occs == NoOccurrences then do_hyps else tclIFTHENTRYELSEMUST (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) do_hyps +let apply_special_clear_request clear_flag f = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + try + let sigma,(c,bl) = f env sigma in + apply_clear_request clear_flag (use_clear_hyp_by_default ()) c + with + e when catchable_exception e -> tclIDTAC + end + type delayed_open_constr_with_bindings = env -> evar_map -> evar_map * constr with_bindings -let general_multi_multi_rewrite with_evars l cl tac = - let do1 l2r f gl = - let sigma,c = f (pf_env gl) (project gl) in - Refiner.tclWITHHOLES with_evars - (general_multi_rewrite l2r with_evars ?tac c) sigma cl gl in +let general_multi_rewrite with_evars l cl tac = + let do1 l2r f = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let sigma,c = f env sigma in + tclWITHHOLES with_evars + (general_rewrite_clause l2r with_evars ?tac c) sigma cl + end + in let rec doN l2r c = function - | Precisely n when n <= 0 -> tclIDTAC + | Precisely n when n <= 0 -> Proofview.tclUNIT () | Precisely 1 -> do1 l2r c | Precisely n -> tclTHENFIRST (do1 l2r c) (doN l2r c (Precisely (n-1))) | RepeatStar -> tclREPEAT_MAIN (do1 l2r c) | RepeatPlus -> tclTHENFIRST (do1 l2r c) (doN l2r c RepeatStar) - | UpTo n when n<=0 -> tclIDTAC + | UpTo n when n<=0 -> Proofview.tclUNIT () | UpTo n -> tclTHENFIRST (tclTRY (do1 l2r c)) (doN l2r c (UpTo (n-1))) in let rec loop = function - | [] -> tclIDTAC - | (l2r,m,c)::l -> tclTHENFIRST (doN l2r c m) (loop l) + | [] -> Proofview.tclUNIT () + | (l2r,m,clear_flag,c)::l -> + tclTHENFIRST + (tclTHEN (doN l2r c m) (apply_special_clear_request clear_flag c)) (loop l) in loop l -let rewriteLR = general_rewrite true all_occurrences true true -let rewriteRL = general_rewrite false all_occurrences true true +let rewriteLR = general_rewrite true AllOccurrences true true +let rewriteRL = general_rewrite false AllOccurrences true true (* Replacing tactics *) +let classes_dirpath = + DirPath.make (List.map Id.of_string ["Classes";"Coq"]) + +let init_setoid () = + if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () + else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] + +let check_setoid cl = + Option.fold_left + ( List.fold_left + (fun b ((occ,_),_) -> + b||(Locusops.occurrences_map (fun x -> x) occ <> AllOccurrences) + ) + ) + ((Locusops.occurrences_map (fun x -> x) cl.concl_occs <> AllOccurrences) && + (Locusops.occurrences_map (fun x -> x) cl.concl_occs <> NoOccurrences)) + cl.onhyps + +let replace_core clause l2r eq = + if check_setoid clause + then init_setoid (); + tclTHENFIRST + (assert_as false None eq) + (onLastHypId (fun id -> + tclTHEN + (tclTRY (general_rewrite_clause l2r false (mkVar id,NoBindings) clause)) + (clear [id]))) + (* eq,sym_eq : equality on Type and its symmetry theorem - c2 c1 : c1 is to be replaced by c2 + c1 c2 : c1 is to be replaced by c2 unsafe : If true, do not check that c1 and c2 are convertible tac : Used to prove the equality c1 = c2 gl : goal *) -let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = +let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = let try_prove_eq = match try_prove_eq_opt with - | None -> tclIDTAC + | None -> Proofview.tclUNIT () | Some tac -> tclCOMPLETE tac in - let t1 = pf_apply get_type_of gl c1 - and t2 = pf_apply get_type_of gl c2 in - if unsafe or (pf_conv_x gl t1 t2) then + Proofview.Goal.enter begin fun gl -> + let get_type_of = pf_apply get_type_of gl in + let t1 = get_type_of c1 + and t2 = get_type_of c2 in + let evd = + if unsafe then Some (Proofview.Goal.sigma gl) + else + try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Proofview.Goal.sigma gl)) + with Evarconv.UnableToUnify _ -> None + in + match evd with + | None -> + tclFAIL 0 (str"Terms do not have convertible types.") + | Some evd -> let e = build_coq_eq () in let sym = build_coq_eq_sym () in + Tacticals.New.pf_constr_of_global sym (fun sym -> + Tacticals.New.pf_constr_of_global e (fun e -> let eq = applist (e, [t1;c1;c2]) in - tclTHENS (assert_as false None eq) - [onLastHypId (fun id -> - tclTHEN - (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) - (clear [id])); - tclFIRST - [assumption; - tclTHEN (apply sym) assumption; - try_prove_eq - ] - ] gl - else - error "Terms do not have convertible types." - - -let replace c2 c1 gl = multi_replace onConcl c2 c1 false None gl - -let replace_in id c2 c1 gl = multi_replace (onHyp id) c2 c1 false None gl + tclTHENLAST + (replace_core clause l2r eq) + (tclFIRST + [assumption; + tclTHEN (apply sym) assumption; + try_prove_eq + ]))) + end -let replace_by c2 c1 tac gl = multi_replace onConcl c2 c1 false (Some tac) gl +let replace c1 c2 = + replace_using_leibniz onConcl c2 c1 false false None -let replace_in_by id c2 c1 tac gl = multi_replace (onHyp id) c2 c1 false (Some tac) gl +let replace_by c1 c2 tac = + replace_using_leibniz onConcl c2 c1 false false (Some tac) -let replace_in_clause_maybe_by c2 c1 cl tac_opt gl = - multi_replace cl c2 c1 false tac_opt gl +let replace_in_clause_maybe_by c1 c2 cl tac_opt = + replace_using_leibniz cl c2 c1 false false tac_opt (* End of Eduardo's code. The rest of this file could be improved using the functions match_with_equation, etc that I defined @@ -541,41 +645,64 @@ let replace_in_clause_maybe_by c2 c1 cl tac_opt gl = exception DiscrFound of (constructor * int) list * constructor * constructor +let injection_on_proofs = ref false + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "injection on prop arguments"; + optkey = ["Injection";"On";"Proofs"]; + optread = (fun () -> !injection_on_proofs) ; + optwrite = (fun b -> injection_on_proofs := b) } + + let find_positions env sigma t1 t2 = + let project env sorts posn t1 t2 = + let ty1 = get_type_of env sigma t1 in + let s = get_sort_family_of env sigma ty1 in + if Sorts.List.mem s sorts + then [(List.rev posn,t1,t2)] else [] + in let rec findrec sorts posn t1 t2 = let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with - - | Construct sp1, Construct sp2 - when List.length args1 = mis_constructor_nargs_env env sp1 + | Construct (sp1,_), Construct (sp2,_) + when Int.equal (List.length args1) (constructor_nallargs_env env sp1) -> - let sorts = list_intersect sorts (allowed_sorts env (fst sp1)) in + let sorts' = + Sorts.List.intersect sorts (allowed_sorts env (fst sp1)) + in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) - if is_conv env sigma hd1 hd2 then - let nrealargs = constructor_nrealargs env sp1 in - let rargs1 = list_lastn nrealargs args1 in - let rargs2 = list_lastn nrealargs args2 in + if eq_constructor sp1 sp2 then + let nrealargs = constructor_nrealargs_env env sp1 in + let rargs1 = List.lastn nrealargs args1 in + let rargs2 = List.lastn nrealargs args2 in List.flatten - (list_map2_i (fun i -> findrec sorts ((sp1,i)::posn)) + (List.map2_i (fun i -> findrec sorts' ((sp1,i)::posn)) 0 rargs1 rargs2) - else if List.mem InType sorts then (* see build_discriminator *) + else if Sorts.List.mem InType sorts' + then (* see build_discriminator *) raise (DiscrFound (List.rev posn,sp1,sp2)) - else [] - + else + (* if we cannot eliminate to Type, we cannot discriminate but we + may still try to project *) + project env sorts posn (applist (hd1,args1)) (applist (hd2,args2)) | _ -> let t1_0 = applist (hd1,args1) and t2_0 = applist (hd2,args2) in if is_conv env sigma t1_0 t2_0 then [] else - let ty1_0 = get_type_of env sigma t1_0 in - let s = get_sort_family_of env sigma ty1_0 in - if List.mem s sorts then [(List.rev posn,t1_0,t2_0)] else [] in + project env sorts posn t1_0 t2_0 + in try - (* Rem: to allow injection on proofs objects, just add InProp *) - Inr (findrec [InSet;InType] [] t1 t2) + let sorts = if !injection_on_proofs then [InSet;InType;InProp] + else [InSet;InType] + in + Inr (findrec sorts [] t1 t2) with DiscrFound (path,c1,c2) -> Inl (path,c1,c2) @@ -638,7 +765,7 @@ let injectable env sigma t1 t2 = *) -(* [descend_then sigma env head dirn] +(* [descend_then env sigma head dirn] returns the number of products introduced, and the environment which is active, in the body of the case-branch given by [dirn], @@ -653,12 +780,13 @@ let injectable env sigma t1 t2 = the continuation then constructs the case-split. *) -let descend_then sigma env head dirn = +let descend_then env sigma head dirn = let IndType (indf,_) = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in - let ind,_ = dest_ind_family indf in + let indp,_ = (dest_ind_family indf) in + let ind, _ = check_privacy env indp in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in @@ -670,11 +798,11 @@ let descend_then sigma env head dirn = let p = it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in let build_branch i = - let result = if i = dirn then dirnval else dfltval in + let result = if Int.equal i dirn then dirnval else dfltval in it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args in let brl = List.map build_branch - (interval 1 (Array.length mip.mind_consnames)) in + (List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, head, Array.of_list brl))) @@ -695,7 +823,7 @@ let descend_then sigma env head dirn = constructs a case-split on [headval], with the [dirn]-th branch giving [True], and all the rest giving False. *) -let construct_discriminator sigma env dirn c sort = +let construct_discriminator env sigma dirn c sort = let IndType(indf,_) = try find_rectype env sigma (get_type_of env sigma c) with Not_found -> @@ -707,26 +835,27 @@ let construct_discriminator sigma env dirn c sort = errorlabstrm "Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in - let (ind,_) = dest_ind_family indf in + let (indp,_) = dest_ind_family indf in + let ind, _ = check_privacy env indp in let (mib,mip) = lookup_mind_specif env ind in let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in let deparsign = make_arity_signature env true indf in let p = it_mkLambda_or_LetIn (mkSort sort_0) deparsign in let cstrs = get_constructors env indf in let build_branch i = - let endpt = if i = dirn then true_0 else false_0 in + let endpt = if Int.equal i dirn then true_0 else false_0 in it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in let brl = - List.map build_branch(interval 1 (Array.length mip.mind_consnames)) in + List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, c, Array.of_list brl) -let rec build_discriminator sigma env dirn c sort = function - | [] -> construct_discriminator sigma env dirn c sort +let rec build_discriminator env sigma dirn c sort = function + | [] -> construct_discriminator env sigma dirn c sort | ((sp,cnum),argnum)::l -> - let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in + let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in - let subval = build_discriminator sigma cnum_env dirn newc sort l in + let subval = build_discriminator cnum_env sigma dirn newc sort l in kont subval (build_coq_False (),mkSort (Prop Null)) (* Note: discrimination could be more clever: if some elimination is @@ -740,13 +869,16 @@ let rec build_discriminator sigma env dirn c sort = function Goal ~ c _ 0 0 = c _ 0 1. intro. discriminate H. *) -let gen_absurdity id gl = - if is_empty_type (pf_get_hyp_typ gl id) +let gen_absurdity id = + Proofview.Goal.enter begin fun gl -> + let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in + let hyp_typ = pf_nf_evar gl hyp_typ in + if is_empty_type hyp_typ then - simplest_elim (mkVar id) gl + simplest_elim (mkVar id) else - errorlabstrm "Equality.gen_absurdity" - (str "Not the negation of an equality.") + Proofview.tclZERO (Errors.UserError ("Equality.gen_absurdity" , str "Not the negation of an equality.")) + end (* Precondition: eq is leibniz equality @@ -756,24 +888,25 @@ let gen_absurdity id gl = *) let ind_scheme_of_eq lbeq = - let (mib,mip) = Global.lookup_inductive (destInd lbeq.eq) in + let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in let kind = inductive_sort_family mip in (* use ind rather than case by compatibility *) let kind = - if kind = InProp then Elimschemes.ind_scheme_kind_from_prop + if kind == InProp then Elimschemes.ind_scheme_kind_from_prop else Elimschemes.ind_scheme_kind_from_type in - mkConst (find_scheme kind (destInd lbeq.eq)) + let c, eff = find_scheme kind (destIndRef lbeq.eq) in + ConstRef c, eff -let discrimination_pf e (t,t1,t2) discriminator lbeq = - let i = build_coq_I () in - let absurd_term = build_coq_False () in - let eq_elim = ind_scheme_of_eq lbeq in - (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term) +let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = + let i = build_coq_I () in + let absurd_term = build_coq_False () in + let eq_elim, eff = ind_scheme_of_eq lbeq in + let sigma, eq_elim = Evd.fresh_global env sigma eq_elim in + sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), + eff -exception NotDiscriminable - -let eq_baseid = id_of_string "e" +let eq_baseid = Id.of_string "e" let apply_on_clause (f,t) clause = let sigma = clause.evd in @@ -788,44 +921,58 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (e,None,t) env in let discriminator = - build_discriminator sigma e_env dirn (mkVar e) sort cpath in - let (pf, absurd_term) = discrimination_pf e (t,t1,t2) discriminator lbeq in + build_discriminator e_env sigma dirn (mkVar e) sort cpath in + let sigma,(pf, absurd_term), eff = + discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in - let pf = clenv_value_cast_meta absurd_clause in - tclTHENS (cut_intro absurd_term) - [onLastHypId gen_absurdity; refine pf] + let pf = Clenvtac.clenv_value_cast_meta absurd_clause in + Proofview.Unsafe.tclEVARS sigma <*> + Proofview.tclEFFECTS eff <*> + tclTHENS (assert_after Anonymous absurd_term) + [onLastHypId gen_absurdity; (Proofview.V82.tactic (refine pf))] -let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause gls = +let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in - let env = pf_env gls in - match find_positions env sigma t1 t2 with + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + match find_positions env sigma t1 t2 with | Inr _ -> - errorlabstrm "discr" (str"Not a discriminable equality.") + Proofview.tclZERO (Errors.UserError ("discr" , str"Not a discriminable equality.")) | Inl (cpath, (_,dirn), _) -> - let sort = pf_apply get_type_of gls (pf_concl gls) in - discr_positions env sigma u eq_clause cpath dirn sort gls - -let onEquality with_evars tac (c,lbindc) gls = - let t = pf_type_of gls c in - let t' = try snd (pf_reduce_to_quantified_ind gls t) with UserError _ -> t in - let eq_clause = make_clenv_binding gls (c,t') lbindc in - let eq_clause' = clenv_pose_dependent_evars with_evars eq_clause in + let sort = pf_apply get_type_of gl concl in + discr_positions env sigma u eq_clause cpath dirn sort + end + +let onEquality with_evars tac (c,lbindc) = + Proofview.Goal.nf_enter begin fun gl -> + let type_of = pf_type_of gl in + let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in + let t = type_of c in + let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in + let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in + let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in - let eq,eq_args = find_this_eq_data_decompose gls eqn in + let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in tclTHEN - (Refiner.tclEVARS eq_clause'.evd) - (tac (eq,eqn,eq_args) eq_clause') gls - -let onNegatedEquality with_evars tac gls = - let ccl = pf_concl gls in - match kind_of_term (hnf_constr (pf_env gls) (project gls) ccl) with - | Prod (_,t,u) when is_empty_type u -> - tclTHEN introf - (onLastHypId (fun id -> - onEquality with_evars tac (mkVar id,NoBindings))) gls - | _ -> - errorlabstrm "" (str "Not a negated primitive equality.") + (Proofview.Unsafe.tclEVARS eq_clause'.evd) + (tac (eq,eqn,eq_args) eq_clause') + end + +let onNegatedEquality with_evars tac = + Proofview.Goal.nf_enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let ccl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + match kind_of_term (hnf_constr env sigma ccl) with + | Prod (_,t,u) when is_empty_type u -> + tclTHEN introf + (onLastHypId (fun id -> + onEquality with_evars tac (mkVar id,NoBindings))) + | _ -> + Proofview.tclZERO (Errors.UserError ("" , str "Not a negated primitive equality.")) + end let discrSimpleClause with_evars = function | None -> onNegatedEquality with_evars discrEq @@ -842,25 +989,25 @@ let discrEverywhere with_evars = (if discr_do_intro () then (tclTHEN (tclREPEAT introf) - (Tacticals.tryAllHyps + (tryAllHyps (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) else (* <= 8.2 compat *) - Tacticals.tryAllHypsAndConcl (discrSimpleClause with_evars)) + tryAllHypsAndConcl (discrSimpleClause with_evars)) (* (fun gls -> errorlabstrm "DiscrEverywhere" (str"No discriminable equalities.")) *) let discr_tac with_evars = function | None -> discrEverywhere with_evars - | Some c -> onInductionArg (discr with_evars) c + | Some c -> onInductionArg (fun clear_flag -> discr with_evars) c -let discrConcl gls = discrClause false onConcl gls -let discrHyp id gls = discrClause false (onHyp id) gls +let discrConcl = discrClause false onConcl +let discrHyp id = discrClause false (onHyp id) (* returns the sigma type (sigS, sigT) with the respective constructor depending on the sort *) (* J.F.: correction du bug #1167 en accord avec Hugo. *) -let find_sigma_data s = build_sigma_type () +let find_sigma_data env s = build_sigma_type () (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser index bound in [rty] @@ -874,16 +1021,18 @@ let find_sigma_data s = build_sigma_type () let make_tuple env sigma (rterm,rty) lind = assert (dependent (mkRel lind) rty); - let {intro = exist_term; typ = sig_term} = - find_sigma_data (get_sort_of env sigma rty) in - let a = type_of env sigma (mkRel lind) in + let sigdata = find_sigma_data env (get_sort_of env sigma rty) in + let sigma, a = e_type_of ~refresh:true env sigma (mkRel lind) in let (na,_,_) = lookup_rel lind env in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) let p = mkLambda (na, a, rty) in - (applist(exist_term,[a;p;(mkRel lind);rterm]), - applist(sig_term,[a;p])) + let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in + let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in + sigma, + (applist(exist_term,[a;p;(mkRel lind);rterm]), + applist(sig_term,[a;p])) (* check that the free-references of the type of [c] are contained in the free-references of the normal-form of that type. Strictly @@ -896,7 +1045,7 @@ let minimal_free_rels env sigma (c,cty) = let cty_rels = free_rels cty in let cty' = simpl env sigma cty in let rels' = free_rels cty' in - if Intset.subset cty_rels rels' then + if Int.Set.subset cty_rels rels' then (cty,cty_rels) else (cty',rels') @@ -906,10 +1055,10 @@ let minimal_free_rels env sigma (c,cty) = let minimal_free_rels_rec env sigma = let rec minimalrec_free_rels_rec prev_rels (c,cty) = let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in - let combined_rels = Intset.union prev_rels direct_rels in + let combined_rels = Int.Set.union prev_rels direct_rels in let folder rels i = snd (minimalrec_free_rels_rec rels (c, type_of env sigma (mkRel i))) - in (cty, List.fold_left folder combined_rels (Intset.elements (Intset.diff direct_rels prev_rels))) - in minimalrec_free_rels_rec Intset.empty + in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels))) + in minimalrec_free_rels_rec Int.Set.empty (* [sig_clausal_form siglen ty] @@ -948,22 +1097,23 @@ let minimal_free_rels_rec env sigma = *) let sig_clausal_form env sigma sort_of_ty siglen ty dflt = - let { intro = exist_term } = find_sigma_data sort_of_ty in + let sigdata = find_sigma_data env sort_of_ty in let evdref = ref (Evd.create_goal_evar_defs sigma) in let rec sigrec_clausal_form siglen p_i = - if siglen = 0 then + if Int.equal siglen 0 then (* is the default value typable with the expected type *) let dflt_typ = type_of env sigma dflt in - if Evarconv.e_cumul env evdref dflt_typ p_i then - (* the_conv_x had a side-effect on evdref *) + try + let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in + let () = evdref := Evarconv.consider_remaining_unif_problems env !evdref in dflt - else + with Evarconv.UnableToUnify _ -> error "Cannot solve a unification problem." else let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with | (_sigS,[a;p]) -> (a,p) - | _ -> anomaly "sig_clausal_form: should be a sigma type" in - let ev = Evarutil.e_new_evar evdref env a in + | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type") in + let ev = Evarutil.e_new_evar env evdref a in let rty = beta_applist(p_i_minus_1,[ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in match @@ -973,13 +1123,14 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = | Some w -> let w_type = type_of env sigma w in if Evarconv.e_cumul env evdref w_type a then - applist(exist_term,[w_type;p_i_minus_1;w;tuple_tail]) + let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in + applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) else error "Cannot solve a unification problem." - | None -> anomaly "Not enough components to build the dependent tuple" + | None -> anomaly (Pp.str "Not enough components to build the dependent tuple") in let scf = sigrec_clausal_form siglen ty in - Evarutil.nf_evar !evdref scf + !evdref, Evarutil.nf_evar !evdref scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors @@ -1012,7 +1163,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = If [zty] has no dependencies, this is simple. Otherwise, assume [zty] has free (de Bruijn) variables in,...i1 then the role of - [make_iterated_tuple sigma env (term,typ) (z,zty)] is to build the + [make_iterated_tuple env sigma (term,typ) (z,zty)] is to build the tuple [existT [xn]Pn Rel(in) .. (existT [x2]P2 Rel(i2) (existT [x1]P1 Rel(i1) z))] @@ -1042,30 +1193,29 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let make_iterated_tuple env sigma dflt (z,zty) = let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in let sort_of_zty = get_sort_of env sigma zty in - let sorted_rels = Sort.list (<) (Intset.elements rels) in - let (tuple,tuplety) = - List.fold_left (make_tuple env sigma) (z,zty) sorted_rels + let sorted_rels = Int.Set.elements rels in + let sigma, (tuple,tuplety) = + List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels in assert (closed0 tuplety); let n = List.length sorted_rels in - let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in - (tuple,tuplety,dfltval) + let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in + sigma, (tuple,tuplety,dfltval) -let rec build_injrec sigma env dflt c = function +let rec build_injrec env sigma dflt c = function | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c) | ((sp,cnum),argnum)::l -> try - let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in + let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in - let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in - (kont subval (dfltval,tuplety), - tuplety,dfltval) + let sigma, (subval,tuplety,dfltval) = build_injrec cnum_env sigma dflt newc l in + sigma, (kont subval (dfltval,tuplety), tuplety,dfltval) with UserError _ -> failwith "caught" -let build_injector sigma env dflt c cpath = - let (injcode,resty,_) = build_injrec sigma env dflt c cpath in - (injcode,resty) +let build_injector env sigma dflt c cpath = + let sigma, (injcode,resty,_) = build_injrec env sigma dflt c cpath in + sigma, (injcode,resty) (* let try_delta_expand env sigma t = @@ -1080,6 +1230,52 @@ let try_delta_expand env sigma t = hd_rec whdt *) +let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") +let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) + +let eqdep_dec = qualid_of_string "Coq.Logic.Eqdep_dec" + +let inject_if_homogenous_dependent_pair ty = + Proofview.Goal.nf_enter begin fun gl -> + try + let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in + (* fetch the informations of the pair *) + let ceq = Universes.constr_of_global Coqlib.glob_eq in + let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in + let existTconstr () = (Coqlib.build_sigma_type()).Coqlib.intro in + (* check whether the equality deals with dep pairs or not *) + let eqTypeDest = fst (decompose_app t) in + if not (Globnames.is_global (sigTconstr()) eqTypeDest) then raise Exit; + let hd1,ar1 = decompose_app_vect t1 and + hd2,ar2 = decompose_app_vect t2 in + if not (Globnames.is_global (existTconstr()) hd1) then raise Exit; + if not (Globnames.is_global (existTconstr()) hd2) then raise Exit; + let ind,_ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in + (* check if the user has declared the dec principle *) + (* and compare the fst arguments of the dep pair *) + (* Note: should work even if not an inductive type, but the table only *) + (* knows inductive types *) + if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) && + pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; + Library.require_library [Loc.ghost,eqdep_dec] (Some false); + let new_eq_args = [|pf_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in + let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" + ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in + let c, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in + (* cut with the good equality and prove the requested goal *) + tclTHENLIST + [Proofview.tclEFFECTS eff; + intro; + onLastHyp (fun hyp -> + tclTHENS (cut (mkApp (ceq,new_eq_args))) + [clear [destVar hyp]; + Proofview.V82.tactic (refine + (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|]))) + ])] + with Exit -> + Proofview.tclUNIT () + end + (* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it expands then only when the whdnf has a constructor of an inductive type in hd position, otherwise delta expansion is not done *) @@ -1091,141 +1287,114 @@ let simplify_args env sigma t = | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2]) | _ -> t -let inject_at_positions env sigma (eq,_,(t,t1,t2)) eq_clause posns tac = +let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (ids_of_context env) in - let e_env = push_named (e,None,t) env in - let injectors = - map_succeed - (fun (cpath,t1',t2') -> - (* arbitrarily take t1' as the injector default value *) - let (injbody,resty) = build_injector sigma e_env t1' (mkVar e) cpath in - let injfun = mkNamedLambda e t injbody in - let pf = applist(eq.congr,[t;resty;injfun;t1;t2]) in - let pf_typ = get_type_of env sigma pf in - let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in - let pf = clenv_value_cast_meta inj_clause in - let ty = simplify_args env sigma (clenv_type inj_clause) in - (pf,ty)) - posns in - if injectors = [] then - errorlabstrm "Equality.inj" (str "Failed to decompose the equality."); - tclTHEN - (tclMAP - (fun (pf,ty) -> tclTHENS (cut ty) [tclIDTAC; refine pf]) - injectors) - (tac (List.length injectors)) - -exception Not_dep_pair - -let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") -let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) - -let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause = + let e_env = push_named (e, None,t) env in + let evdref = ref sigma in + let filter (cpath, t1', t2') = + try + (* arbitrarily take t1' as the injector default value *) + let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in + let injfun = mkNamedLambda e t injbody in + let sigma,congr = Evd.fresh_global env sigma eq.congr in + let pf = applist(congr,[t;resty;injfun;t1;t2]) in + let sigma, pf_typ = Typing.e_type_of env sigma pf in + let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in + let pf = Clenvtac.clenv_value_cast_meta inj_clause in + let ty = simplify_args env sigma (clenv_type inj_clause) in + evdref := sigma; + Some (pf, ty) + with Failure _ -> None + in + let injectors = List.map_filter filter posns in + if List.is_empty injectors then + Proofview.tclZERO (Errors.UserError ("Equality.inj" , str "Failed to decompose the equality.")) + else + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) + (Proofview.tclBIND + (Proofview.Monad.List.map + (fun (pf,ty) -> tclTHENS (cut ty) + [inject_if_homogenous_dependent_pair ty; + Proofview.V82.tactic (refine pf)]) + (if l2r then List.rev injectors else injectors)) + (fun _ -> tac (List.length injectors))) + +let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in let env = eq_clause.env in match find_positions env sigma t1 t2 with - | Inl _ -> - errorlabstrm "Inj" - (str"Not a projectable equality but a discriminable one.") - | 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 - let t2 = try_delta_expand env sigma t2 in -*) - try ( -(* fetch the informations of the pair *) - let ceq = constr_of_global Coqlib.glob_eq in - let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in - let eqTypeDest = fst (destApp t) in - let _,ar1 = destApp t1 and - _,ar2 = destApp t2 in - let ind = destInd ar1.(0) in - let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" - ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in -(* check whether the equality deals with dep pairs or not *) -(* if yes, check if the user has declared the dec principle *) -(* and compare the fst arguments of the dep pair *) - let new_eq_args = [|type_of env sigma (ar1.(3));ar1.(3);ar2.(3)|] in - if ( (eqTypeDest = sigTconstr()) && - (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind=true) && - (is_conv env sigma (ar1.(2)) (ar2.(2)) = true)) - then ( -(* Require Import Eqdec_dec copied from vernac_require in vernacentries.ml*) - let qidl = qualid_of_reference - (Ident (dummy_loc,id_of_string "Eqdep_dec")) in - Library.require_library [qidl] (Some false); -(* cut with the good equality and prove the requested goal *) - tclTHENS (cut (mkApp (ceq,new_eq_args)) ) - [tclIDTAC; tclTHEN (apply ( - mkApp(inj2, - [|ar1.(0);mkConst (find_scheme (!eq_dec_scheme_kind_name()) ind); - ar1.(1);ar1.(2);ar1.(3);ar2.(3)|]) - )) (Auto.trivial [] []) - ] -(* not a dep eq or no decidable type found *) - ) else (raise Not_dep_pair) - ) with e when Errors.noncritical e -> - inject_at_positions env sigma u eq_clause posns - (fun _ -> intros_pattern no_move ipats) - -let inj ipats with_evars = onEquality with_evars (injEq ipats) + | Inl _ -> + Proofview.tclZERO (Errors.UserError ("Inj",strbrk"This equality is discriminable. You should use the discriminate tactic to solve the goal.")) + | Inr [] -> + let suggestion = if !injection_on_proofs then "" else " You can try to use option Set Injection On Proofs." in + Proofview.tclZERO (Errors.UserError ("Equality.inj",strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion))) + | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 -> + Proofview.tclZERO (Errors.UserError ("Equality.inj" , str"Nothing to inject.")) + | Inr posns -> + inject_at_positions env sigma l2r u eq_clause posns + (tac (clenv_value eq_clause)) + +let use_clear_hyp_by_default () = false + +let postInjEqTac clear_flag ipats c n = + match ipats with + | Some ipats -> + let clear_tac = + let dft = + use_injection_pattern_l2r_order () || use_clear_hyp_by_default () in + tclTRY (apply_clear_request clear_flag dft c) in + let intro_tac = + if use_injection_pattern_l2r_order () + then intro_patterns_bound_to n MoveLast ipats + else intro_patterns_to MoveLast ipats in + tclTHEN clear_tac intro_tac + | None -> tclIDTAC + +let injEq clear_flag ipats = + let l2r = + if use_injection_pattern_l2r_order () && not (Option.is_empty ipats) then true else false + in + injEqThen (fun c i -> postInjEqTac clear_flag ipats c i) l2r + +let inj ipats with_evars clear_flag = onEquality with_evars (injEq clear_flag ipats) let injClause ipats with_evars = function - | None -> onNegatedEquality with_evars (injEq ipats) + | None -> onNegatedEquality with_evars (injEq None ipats) | Some c -> onInductionArg (inj ipats with_evars) c -let injConcl gls = injClause [] false None gls -let injHyp id gls = injClause [] false (Some (ElimOnIdent (dummy_loc,id))) gls - -let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause gls = - let sort = pf_apply get_type_of gls (pf_concl gls) in - let sigma = clause.evd in - let env = pf_env gls in - match find_positions env sigma t1 t2 with - | Inl (cpath, (_,dirn), _) -> - discr_positions env sigma u clause cpath dirn sort gls - | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) - ntac 0 gls +let injConcl = injClause None false None +let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.ghost,id))) + +let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = + Proofview.Goal.nf_enter begin fun gl -> + let sort = pf_apply get_type_of gl (Proofview.Goal.concl gl) in + let sigma = clause.evd in + let env = Proofview.Goal.env gl in + match find_positions env sigma t1 t2 with + | Inl (cpath, (_,dirn), _) -> + discr_positions env sigma u clause cpath dirn sort + | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) + ntac (clenv_value clause) 0 | Inr posns -> - inject_at_positions env sigma u clause (List.rev posns) ntac gls + inject_at_positions env sigma true u clause posns + (ntac (clenv_value clause)) + end let dEqThen with_evars ntac = function - | None -> onNegatedEquality with_evars (decompEqThen ntac) - | Some c -> onInductionArg (onEquality with_evars (decompEqThen ntac)) c - -let dEq with_evars = dEqThen with_evars (fun x -> tclIDTAC) - -let swap_equality_args = function - | MonomorphicLeibnizEq (e1,e2) -> [e2;e1] - | PolymorphicLeibnizEq (t,e1,e2) -> [t;e2;e1] - | HeterogenousEq (t1,e1,t2,e2) -> [t2;e2;t1;e1] - -let swap_equands gls eqn = - let (lbeq,eq_args) = find_eq_data eqn in - applist(lbeq.eq,swap_equality_args eq_args) - -let swapEquandsInConcl gls = - let (lbeq,eq_args) = find_eq_data (pf_concl gls) in - let sym_equal = lbeq.sym in - refine - (applist(sym_equal,(swap_equality_args eq_args@[Evarutil.mk_new_meta()]))) - gls - -(* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *) - -let bareRevSubstInConcl lbeq body (t,e1,e2) gls = - (* find substitution scheme *) - let eq_elim = find_elim lbeq.eq (Some false) false None None gls in - (* build substitution predicate *) - let p = lambda_create (pf_env gls) (t,body) in - (* apply substitution scheme *) - refine (applist(eq_elim,[t;e1;p;Evarutil.mk_new_meta(); - e2;Evarutil.mk_new_meta()])) gls + | None -> onNegatedEquality with_evars (decompEqThen (ntac None)) + | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (decompEqThen (ntac clear_flag))) c + +let dEq with_evars = + dEqThen with_evars (fun clear_flag c x -> + (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) + +let intro_decompe_eq tac data cl = + Proofview.Goal.enter begin fun gl -> + let cl = pf_apply make_clenv_binding gl cl NoBindings in + decompEqThen (fun _ -> tac) data cl + end + +let _ = declare_intro_decomp_eq intro_decompe_eq (* [subst_tuple_term dep_pair B] @@ -1263,17 +1432,15 @@ let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = let iterated_decomp = try - let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in - let car_code = applist (p1,[a;p;inner_code]) - and cdr_code = applist (p2,[a;p;inner_code]) in + let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in + let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) + and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in let cdrtyp = beta_applist (p,[car]) in List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) - with PatternMatchingFailure -> + with Constr_matching.PatternMatchingFailure -> [] - in - [((ex,exty),inner_code)]::iterated_decomp - in - decomprec (mkRel 1) c t + in [((ex,exty),inner_code)]::iterated_decomp + in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let typ = get_type_of env sigma dep_pair1 in @@ -1293,78 +1460,80 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = List.fold_right (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in let pred_body = beta_applist(abst_B,proj_list) in + let body = mkApp (lambda_create env (typ,pred_body),[|dep_pair1|]) in let expected_goal = beta_applist (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma expected_goal in - pred_body,expected_goal + (* Retype to get universes right *) + let sigma, expected_goal_ty = Typing.e_type_of env sigma expected_goal in + let sigma, _ = Typing.e_type_of env sigma body in + sigma,body,expected_goal -(* Like "replace" but decompose dependent equalities *) +(* Like "replace" but decompose dependent equalities *) +(* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *) +(* then it uses the predicate "\x.phi(proj1_sig x,proj2_sig x)", and so *) +(* on for further iterated sigma-tuples *) exception NothingToRewrite -let cutSubstInConcl_RL eqn gls = - let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in - let body,expected_goal = pf_apply subst_tuple_term gls e2 e1 (pf_concl gls) in - if not (dependent (mkRel 1) body) then raise NothingToRewrite; +let cutSubstInConcl l2r eqn = + Proofview.Goal.nf_enter begin fun gl -> + let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in + let typ = pf_concl gl in + let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in + let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in tclTHENFIRST - (bareRevSubstInConcl lbeq body eq) - (convert_concl expected_goal DEFAULTcast) gls + (tclTHENLIST [ + (Proofview.Unsafe.tclEVARS sigma); + (change_concl typ); (* Put in pattern form *) + (replace_core onConcl l2r eqn) + ]) + (change_concl expected) (* Put in normalized form *) + end + +let cutSubstInHyp l2r eqn id = + Proofview.Goal.nf_enter begin fun gl -> + let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in + let typ = pf_get_hyp_typ id gl in + let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in + let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in + tclTHENFIRST + (tclTHENLIST [ + (Proofview.Unsafe.tclEVARS sigma); + (change_in_hyp None (fun s -> s,typ) (id,InHypTypeOnly)); + (replace_core (onHyp id) l2r eqn) + ]) + (change_in_hyp None (fun s -> s,expected) (id,InHypTypeOnly)) + end -(* |- (P e1) - BY CutSubstInConcl_LR (eq T e1 e2) - |- (P e2) - |- (eq T e1 e2) - *) -let cutSubstInConcl_LR eqn gls = - (tclTHENS (cutSubstInConcl_RL (swap_equands gls eqn)) - ([tclIDTAC; - swapEquandsInConcl])) gls - -let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL - -let cutSubstInHyp_LR eqn id gls = - let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in - let idtyp = pf_get_hyp_typ gls id in - let body,expected_goal = pf_apply subst_tuple_term gls e1 e2 idtyp in - if not (dependent (mkRel 1) body) then raise NothingToRewrite; - cut_replacing id expected_goal - (tclTHENFIRST - (bareRevSubstInConcl lbeq body eq) - (refine_no_check (mkVar id))) gls - -let cutSubstInHyp_RL eqn id gls = - (tclTHENS (cutSubstInHyp_LR (swap_equands gls eqn) id) - ([tclIDTAC; - swapEquandsInConcl])) gls - -let cutSubstInHyp l2r = if l2r then cutSubstInHyp_LR else cutSubstInHyp_RL - -let try_rewrite tac gls = - try - tac gls - with - | PatternMatchingFailure -> - errorlabstrm "try_rewrite" (str "Not a primitive equality here.") +let try_rewrite tac = + Proofview.tclORELSE tac begin function (e, info) -> match e with + | Constr_matching.PatternMatchingFailure -> + tclZEROMSG (str "Not a primitive equality here.") | e when catchable_exception e -> - errorlabstrm "try_rewrite" + tclZEROMSG (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") | NothingToRewrite -> - errorlabstrm "try_rewrite" + tclZEROMSG (strbrk "Nothing to rewrite.") + | e -> Proofview.tclZERO ~info e + end -let cutSubstClause l2r eqn cls gls = +let cutSubstClause l2r eqn cls = match cls with - | None -> cutSubstInConcl l2r eqn gls - | Some id -> cutSubstInHyp l2r eqn id gls + | None -> cutSubstInConcl l2r eqn + | Some id -> cutSubstInHyp l2r eqn id let cutRewriteClause l2r eqn cls = try_rewrite (cutSubstClause l2r eqn cls) let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None -let substClause l2r c cls gls = - let eq = pf_apply get_type_of gls c in +let substClause l2r c cls = + Proofview.Goal.enter begin fun gl -> + let eq = pf_apply get_type_of gl c in tclTHENS (cutSubstClause l2r eq cls) - [tclIDTAC; exact_no_check c] gls + [Proofview.tclUNIT (); Proofview.V82.tactic (exact_no_check c)] + end let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) let rewriteInHyp l2r c id = rewriteClause l2r c (Some id) @@ -1389,100 +1558,102 @@ user = raise user error specific to rewrite (**********************************************************************) (* Substitutions tactics (JCF) *) -let unfold_body x gl = - let hyps = pf_hyps gl in - let xval = - match Sign.lookup_named x hyps with - (_,Some xval,_) -> xval - | _ -> errorlabstrm "unfold_body" - (pr_id x ++ str" is not a defined hypothesis.") in - let aft = afterHyp x gl in +let unfold_body x = + Proofview.Goal.enter begin fun gl -> + (** We normalize the given hypothesis immediately. *) + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let (_, xval, _) = Context.lookup_named x hyps in + let xval = match xval with + | None -> errorlabstrm "unfold_body" + (pr_id x ++ str" is not a defined hypothesis.") + | Some xval -> pf_nf_evar gl xval + in + afterHyp x begin fun aft -> let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in - tclTHENLIST - [tclMAP (fun h -> reduct_in_hyp rfun h) hl; - reduct_in_concl (rfun,DEFAULTcast)] gl - - + let reducth h = Proofview.V82.tactic (fun gl -> reduct_in_hyp rfun h gl) in + let reductc = Proofview.V82.tactic (fun gl -> reduct_in_concl (rfun, DEFAULTcast) gl) in + tclTHENLIST [tclMAP reducth hl; reductc] + end + end let restrict_to_eq_and_identity eq = (* compatibility *) - if eq <> constr_of_global glob_eq && eq <> constr_of_global glob_identity then - raise PatternMatchingFailure + if not (is_global glob_eq eq) && + not (is_global glob_identity eq) + then raise Constr_matching.PatternMatchingFailure -exception FoundHyp of (identifier * constr * bool) +exception FoundHyp of (Id.t * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *) let is_eq_x gl x (id,_,c) = try - let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in - if (eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); - if (eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) - with PatternMatchingFailure -> + let c = pf_nf_evar gl c in + let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in + if (Term.eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); + if (Term.eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) + with Constr_matching.PatternMatchingFailure -> () (* 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 = +let subst_one dep_proof_ok x (hyp,rhs,dir) = + Proofview.Goal.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let hyps = Proofview.Goal.hyps gl in + let concl = Proofview.Goal.concl gl in (* 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 (pf_hyps gl)) in - let dephyps = List.map (fun (id,_,_) -> id) depdecls in + let dephyps = + List.rev (snd (List.fold_right (fun (id,b,_ as dcl) (deps,allhyps) -> + if not (Id.equal id hyp) + && List.exists (fun y -> occur_var_in_decl env y dcl) deps + then + ((if b = None then deps else id::deps), id::allhyps) + else + (deps,allhyps)) + hyps + ([x],[]))) in (* Decides if x appears in conclusion *) - let depconcl = occur_var (pf_env gl) x (pf_concl gl) in - (* The set of non-defined hypothesis: they must be abstracted, - rewritten and reintroduced *) - let abshyps = - map_succeed - (fun (id,v,_) -> if v=None then mkVar id else failwith "caught") - depdecls in - (* a tactic that either introduce an abstracted and rewritten hyp, - or introduce a definition where x was replaced *) - let introtac = function - (id,None,_) -> intro_using id - | (id,Some hval,htyp) -> - letin_tac None (Name id) - (replace_term (mkVar x) rhs hval) - (Some (replace_term (mkVar x) rhs htyp)) nowhere - in - let need_rewrite = dephyps <> [] || depconcl in + let depconcl = occur_var env x concl in + let need_rewrite = not (List.is_empty dephyps) || depconcl in tclTHENLIST ((if need_rewrite then - [generalize abshyps; - general_rewrite dir all_occurrences true dep_proof_ok (mkVar hyp); - thin dephyps; - tclMAP introtac depdecls] + [revert dephyps; + general_rewrite dir AllOccurrences true dep_proof_ok (mkVar hyp); + (tclMAP intro_using dephyps)] else - [tclIDTAC]) @ - [tclTRY (clear [x;hyp])]) gl + [Proofview.tclUNIT ()]) @ + [tclTRY (clear [x; hyp])]) + end (* 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_one_var dep_proof_ok x = + Proofview.Goal.enter begin fun gl -> + let gl = Proofview.Goal.assume gl in + let (_,xval,_) = pf_get_hyp x gl in + (* If x has a body, simply replace x with body and clear x *) + if not (Option.is_empty xval) then tclTHEN (unfold_body x) (clear [x]) else + (* x is a variable: *) + let varx = mkVar x in + (* Find a non-recursive definition for x *) + let res = + try + (** [is_eq_x] ensures nf_evar on its side *) + let hyps = Proofview.Goal.hyps gl in + let test hyp _ = is_eq_x gl varx hyp in + Context.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 res + end let subst_gen dep_proof_ok ids = - tclTHEN tclNORMEVAR (tclMAP (subst_one_var dep_proof_ok) ids) + tclTHEN Proofview.V82.nf_evar_goals (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 @@ -1501,67 +1672,82 @@ let default_subst_tactic_flags () = else { only_leibniz = true; rewrite_dependent_proof = false } -let subst_all ?(flags=default_subst_tactic_flags ()) gl = +let subst_all ?(flags=default_subst_tactic_flags ()) () = + Proofview.Goal.nf_enter begin fun gl -> + let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = try - let lbeq,(_,x,y) = find_eq_data_decompose gl c in - if flags.only_leibniz then restrict_to_eq_and_identity lbeq.eq; + let lbeq,u,(_,x,y) = find_eq_data_decompose c in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + if flags.only_leibniz then restrict_to_eq_and_identity eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) - if eq_constr x y then failwith "caught"; + if Term.eq_constr x y then failwith "caught"; match kind_of_term x with Var x -> x | _ -> match kind_of_term y with Var y -> y | _ -> failwith "caught" - with PatternMatchingFailure -> failwith "caught" + with Constr_matching.PatternMatchingFailure -> failwith "caught" in - let ids = map_succeed test (pf_hyps_types gl) in - let ids = list_uniquize ids in - subst_gen flags.rewrite_dependent_proof ids gl + let test p = try Some (test p) with Failure _ -> None in + let hyps = pf_hyps_types gl in + let ids = List.map_filter test hyps in + let ids = List.uniquize ids in + subst_gen flags.rewrite_dependent_proof ids + end -(* Rewrite the first assumption for which the condition faildir does not fail +(* Rewrite the first assumption for which a condition holds and gives the direction of the rewrite *) let cond_eq_term_left c t gl = try - let (_,x,_) = snd (find_eq_data_decompose gl t) in + let (_,x,_) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else failwith "not convertible" - with PatternMatchingFailure -> failwith "not an equality" + with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try - let (_,_,x) = snd (find_eq_data_decompose gl t) in + let (_,_,x) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then false else failwith "not convertible" - with PatternMatchingFailure -> failwith "not an equality" + with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try - let (_,x,y) = snd (find_eq_data_decompose gl t) in + let (_,x,y) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else if pf_conv_x gl c y then false else failwith "not convertible" - with PatternMatchingFailure -> failwith "not an equality" + with Constr_matching.PatternMatchingFailure -> failwith "not an equality" -let rewrite_multi_assumption_cond cond_eq_term cl gl = - let rec arec = function +let rewrite_assumption_cond cond_eq_term cl = + let rec arec hyps gl = match hyps with | [] -> error "No such assumption." | (id,_,t) ::rest -> begin try - let dir = cond_eq_term t gl in - general_multi_rewrite dir false (mkVar id,NoBindings) cl gl - with | Failure _ | UserError _ -> arec rest + let dir = cond_eq_term t gl in + general_rewrite_clause dir false (mkVar id,NoBindings) cl + with | Failure _ | UserError _ -> arec rest gl end in - arec (pf_hyps gl) + Proofview.Goal.nf_enter begin fun gl -> + let hyps = Proofview.Goal.hyps gl in + arec hyps gl + end -let replace_multi_term dir_opt c = +(* Generalize "subst x" to substitution of subterm appearing as an + equation in the context, but not clearing the hypothesis *) + +let replace_term dir_opt c = let cond_eq_fun = match dir_opt with | None -> cond_eq_term c | Some true -> cond_eq_term_left c | Some false -> cond_eq_term_right c in - rewrite_multi_assumption_cond cond_eq_fun + rewrite_assumption_cond cond_eq_fun + +(* Declare rewriting tactic for intro patterns "<-" and "->" *) -let _ = Tactics.register_general_multi_rewrite - (fun b evars t cls -> general_multi_rewrite b evars t cls) +let _ = + let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars tac c in + Hook.set Tactics.general_rewrite_clause gmr -let _ = Tactics.register_subst_one (fun b -> subst_one b) +let _ = Hook.set Tactics.subst_one subst_one diff --git a/tactics/equality.mli b/tactics/equality.mli index 75a59e6d..90d8a224 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -1,29 +1,21 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* occurrences -> freeze_evars_flag -> dep_proof_flag -> - ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic + ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic val general_rewrite : orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> - ?tac:(tactic * conditions) -> constr -> tactic + ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic (* Equivalent to [general_rewrite l2r] *) -val rewriteLR : ?tac:(tactic * conditions) -> constr -> tactic -val rewriteRL : ?tac:(tactic * conditions) -> constr -> tactic +val rewriteLR : ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic +val rewriteRL : ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic (* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *) -val register_general_rewrite_clause : - (identifier option -> orientation -> - occurrences -> constr with_bindings -> new_goals:constr list -> tactic) -> unit -val register_is_applied_rewrite_relation : (env -> evar_map -> rel_context -> constr -> constr option) -> unit +val general_setoid_rewrite_clause : + (Id.t option -> orientation -> occurrences -> constr with_bindings -> + new_goals:constr list -> unit Proofview.tactic) Hook.t -val general_rewrite_ebindings_clause : identifier option -> +val general_rewrite_ebindings_clause : Id.t option -> orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> - ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic + ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic val general_rewrite_bindings_in : orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> - ?tac:(tactic * conditions) -> - identifier -> constr with_bindings -> evars_flag -> tactic + ?tac:(unit Proofview.tactic * conditions) -> + Id.t -> constr with_bindings -> evars_flag -> unit Proofview.tactic val general_rewrite_in : orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> - ?tac:(tactic * conditions) -> identifier -> constr -> evars_flag -> tactic + ?tac:(unit Proofview.tactic * conditions) -> Id.t -> constr -> evars_flag -> unit Proofview.tactic + +val general_rewrite_clause : + orientation -> evars_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> clause -> unit Proofview.tactic val general_multi_rewrite : - orientation -> evars_flag -> ?tac:(tactic * conditions) -> constr with_bindings -> clause -> tactic - -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 -> - clause -> (tactic * conditions) option -> tactic - -val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic -val replace : constr -> constr -> tactic -val replace_in : identifier -> constr -> constr -> tactic -val replace_by : constr -> constr -> tactic -> tactic -val replace_in_by : identifier -> constr -> constr -> tactic -> tactic - -val discr : evars_flag -> constr with_bindings -> tactic -val discrConcl : tactic -val discrClause : evars_flag -> clause -> tactic -val discrHyp : identifier -> tactic -val discrEverywhere : evars_flag -> tactic + evars_flag -> (bool * multi * clear_flag * delayed_open_constr_with_bindings) list -> + clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic + +val replace_in_clause_maybe_by : constr -> constr -> clause -> unit Proofview.tactic option -> unit Proofview.tactic +val replace : constr -> constr -> unit Proofview.tactic +val replace_by : constr -> constr -> unit Proofview.tactic -> unit Proofview.tactic + +val discr : evars_flag -> constr with_bindings -> unit Proofview.tactic +val discrConcl : unit Proofview.tactic +val discrHyp : Id.t -> unit Proofview.tactic +val discrEverywhere : evars_flag -> unit Proofview.tactic val discr_tac : evars_flag -> - constr with_bindings induction_arg option -> tactic -val inj : intro_pattern_expr located list -> evars_flag -> - constr with_bindings -> tactic -val injClause : intro_pattern_expr located list -> evars_flag -> - constr with_bindings induction_arg option -> tactic -val injHyp : identifier -> tactic -val injConcl : tactic + constr with_bindings induction_arg option -> unit Proofview.tactic +val inj : intro_patterns option -> evars_flag -> + clear_flag -> constr with_bindings -> unit Proofview.tactic +val injClause : intro_patterns option -> evars_flag -> + constr with_bindings induction_arg option -> unit Proofview.tactic +val injHyp : clear_flag -> Id.t -> unit Proofview.tactic +val injConcl : unit Proofview.tactic -val dEq : evars_flag -> constr with_bindings induction_arg option -> tactic -val dEqThen : evars_flag -> (int -> tactic) -> constr with_bindings induction_arg option -> tactic +val dEq : evars_flag -> constr with_bindings induction_arg option -> unit Proofview.tactic +val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings induction_arg option -> unit Proofview.tactic val make_iterated_tuple : - env -> evar_map -> constr -> (constr * types) -> constr * constr * constr + env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) (* The family cutRewriteIn expect an equality statement *) -val cutRewriteInHyp : bool -> types -> identifier -> tactic -val cutRewriteInConcl : bool -> constr -> tactic +val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic +val cutRewriteInConcl : bool -> constr -> unit Proofview.tactic (* The family rewriteIn expect the proof of an equality *) -val rewriteInHyp : bool -> constr -> identifier -> tactic -val rewriteInConcl : bool -> constr -> tactic - -(* Expect the proof of an equality; fails with raw internal errors *) -val substClause : bool -> constr -> identifier option -> tactic +val rewriteInHyp : bool -> constr -> Id.t -> unit Proofview.tactic +val rewriteInConcl : bool -> constr -> unit Proofview.tactic val discriminable : env -> evar_map -> constr -> constr -> bool val injectable : env -> evar_map -> constr -> constr -> bool (* Subst *) -val unfold_body : identifier -> tactic +(* val unfold_body : Id.t -> tactic *) type subst_tactic_flags = { only_leibniz : bool; rewrite_dependent_proof : bool } -val subst_gen : bool -> identifier list -> tactic -val subst : identifier list -> tactic -val subst_all : ?flags:subst_tactic_flags -> tactic +val subst_gen : bool -> Id.t list -> unit Proofview.tactic +val subst : Id.t list -> unit Proofview.tactic +val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic (* Replace term *) -(* [replace_multi_term dir_opt c cl] +(* [replace_term dir_opt c cl] perfoms replacement of [c] by the first value found in context (according to [dir] if given to get the rewrite direction) in the clause [cl] *) -val replace_multi_term : bool option -> constr -> clause -> tactic +val replace_term : bool option -> constr -> clause -> unit Proofview.tactic val set_eq_dec_scheme_kind : mutual scheme_kind -> unit diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index e9a041d7..2aafaf08 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -1,57 +1,79 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let sigma = gl.sigma in let evl = match ido with - ConclLocation () -> evar_list sigma (pf_concl gl) + ConclLocation () -> evar_list (pf_concl gl) | HypLocation (id,hloc) -> let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in match hloc with InHyp -> (match decl with - (_,None,typ) -> evar_list sigma typ + (_,None,typ) -> evar_list typ | _ -> error "Please be more specific: in type or value?") | InHypTypeOnly -> - let (_, _, typ) = decl in evar_list sigma typ + let (_, _, typ) = decl in evar_list typ | InHypValueOnly -> (match decl with - (_,Some body,_) -> evar_list sigma body + (_,Some body,_) -> evar_list body | _ -> error "Not a defined hypothesis.") in - if List.length evl < n then - error "Not enough uninstantiated existential variables."; - if n <= 0 then error "Incorrect existential variable index."; - let evk,_ = List.nth evl (n-1) in - let evi = Evd.find sigma evk in - let ltac_vars = Tacinterp.extract_ltac_constr_values ist (Evd.evar_env evi) in - let sigma' = w_refine (evk,evi) (ltac_vars,rawc) sigma in - tclTHEN - (tclEVARS sigma') - tclNORMEVAR - gl + if List.length evl < n then + error "Not enough uninstantiated existential variables."; + if n <= 0 then error "Incorrect existential variable index."; + let evk,_ = List.nth evl (n-1) in + instantiate_evar evk c sigma gl + end + +let instantiate_tac_by_name id c = + Proofview.V82.tactic begin fun gl -> + let sigma = gl.sigma in + let evk = + try Evd.evar_key id sigma + with Not_found -> error "Unknown existential variable." in + instantiate_evar evk c sigma gl + end -let let_evar name typ gls = - let src = (dummy_loc,GoalEvar) in - 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 +let let_evar name typ = + let src = (Loc.ghost,Evar_kinds.GoalEvar) in + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let id = Namegen.id_of_name_using_hdchar env typ name in + let id = Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) in + let sigma',evar = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS sigma')) + (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) + end diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli index f4e1ed80..42d00e1e 100644 --- a/tactics/evar_tactics.mli +++ b/tactics/evar_tactics.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tacinterp.interp_sign * Glob_term.glob_constr -> - (identifier * hyp_location_flag, unit) location -> tactic +val instantiate_tac : int -> Tacinterp.interp_sign * Glob_term.glob_constr -> + (Id.t * hyp_location_flag, unit) location -> unit Proofview.tactic -val let_evar : name -> Term.types -> tactic +val instantiate_tac_by_name : Id.t -> + Tacinterp.interp_sign * Glob_term.glob_constr -> unit Proofview.tactic + +val let_evar : Name.t -> Term.types -> unit Proofview.tactic diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 88271fd6..47987e9e 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -1,20 +1,21 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* pr_int_list x | ArgVar (loc, id) -> Nameops.pr_id id -let coerce_to_int = function - | VInteger n -> n - | v -> raise (CannotCoerceTo "an integer") +let occurrences_of = function + | [] -> NoOccurrences + | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl) + | nl -> + if List.exists (fun n -> n < 0) nl then + Errors.error "Illegal negative occurrence number."; + OnlyOccurrences nl + +let coerce_to_int v = match Value.to_int v with + | None -> raise (CannotCoerceTo "an integer") + | Some n -> n -let int_list_of_VList = function - | VList l -> List.map (fun n -> coerce_to_int n) l - | _ -> raise Not_found +let int_list_of_VList v = match Value.to_list v with +| Some l -> List.map (fun n -> coerce_to_int n) l +| _ -> raise (CannotCoerceTo "an integer") let interp_occs ist gl l = match l with | ArgArg x -> x | ArgVar (_,id as locid) -> - (try int_list_of_VList (List.assoc id ist.lfun) + (try int_list_of_VList (Id.Map.find id ist.lfun) with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) let interp_occs ist gl l = Tacmach.project gl , interp_occs ist gl l @@ -65,9 +72,6 @@ let glob_occs ist l = l let subst_occs evm l = l -type occurrences_or_var = int list or_var -type occurrences = int list - ARGUMENT EXTEND occurrences PRINTED BY pr_int_list_full @@ -93,9 +97,9 @@ let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) -let glob_glob = Tacinterp.intern_constr +let glob_glob = Tacintern.intern_constr -let subst_glob = Tacinterp.subst_glob_constr_and_expr +let subst_glob = Tacsubst.subst_glob_constr_and_expr ARGUMENT EXTEND glob PRINTED BY pr_globc @@ -109,14 +113,28 @@ ARGUMENT EXTEND glob GLOB_TYPED AS glob_constr_and_expr GLOB_PRINTED BY pr_gen - [ lconstr(c) ] -> [ c ] + [ constr(c) ] -> [ c ] END +ARGUMENT EXTEND lglob + PRINTED BY pr_globc + + 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 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 -type place = identifier gen_place +type loc_place = Id.t Loc.located gen_place +type place = Id.t gen_place let pr_gen_place pr_id = function ConclLocation () -> Pp.mt () @@ -132,14 +150,14 @@ let pr_hloc = pr_loc_place () () () let intern_place ist = function ConclLocation () -> ConclLocation () - | HypLocation (id,hl) -> HypLocation (intern_hyp ist id,hl) + | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl) -let interp_place ist gl = function +let interp_place ist env sigma = function ConclLocation () -> ConclLocation () - | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl) + | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl) let interp_place ist gl p = - Tacmach.project gl , interp_place ist gl p + Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p let subst_place subst pl = pl @@ -157,11 +175,11 @@ ARGUMENT EXTEND hloc | [ "in" "|-" "*" ] -> [ ConclLocation () ] | [ "in" ident(id) ] -> - [ HypLocation ((Util.dummy_loc,id),InHyp) ] + [ HypLocation ((Loc.ghost,id),InHyp) ] | [ "in" "(" "Type" "of" ident(id) ")" ] -> - [ HypLocation ((Util.dummy_loc,id),InHypTypeOnly) ] + [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ] | [ "in" "(" "Value" "of" ident(id) ")" ] -> - [ HypLocation ((Util.dummy_loc,id),InHypValueOnly) ] + [ HypLocation ((Loc.ghost,id),InHypValueOnly) ] END @@ -187,115 +205,16 @@ 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 - | Some [],true -> mt () - | None,true -> str "in" ++ spc () ++ str "*" - | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-" - | Some l,_ -> - str "in" ++ - spc () ++ Util.prlist_with_sep Util.pr_comma pr_id l ++ - match concl with - | true -> spc () ++ str "|-" ++ spc () ++ str "*" - | _ -> mt () - - -let pr_in_arg_hyp _ _ _ = pr_in_hyp (fun (_,id) -> Ppconstr.pr_id id) - -let pr_in_arg_hyp_typed _ _ _ = pr_in_hyp Ppconstr.pr_id - - -let pr_var_list_gen pr_id = Util.prlist_with_sep (fun () -> str ",") pr_id - -let pr_var_list_typed _ _ _ = pr_var_list_gen Ppconstr.pr_id - -let pr_var_list _ _ _ = pr_var_list_gen (fun (_,id) -> Ppconstr.pr_id id) - - -ARGUMENT EXTEND comma_var_lne - PRINTED BY pr_var_list_typed - RAW_TYPED AS var list - RAW_PRINTED BY pr_var_list - GLOB_TYPED AS var list - GLOB_PRINTED BY pr_var_list -| [ var(x) ] -> [ [x] ] -| [ var(x) "," comma_var_lne(l) ] -> [x::l] -END - -ARGUMENT EXTEND comma_var_l - PRINTED BY pr_var_list_typed - RAW_TYPED AS var list - RAW_PRINTED BY pr_var_list - GLOB_TYPED AS var list - GLOB_PRINTED BY pr_var_list -| [ comma_var_lne(l) ] -> [l] -| [] -> [ [] ] -END - -let pr_in_concl _ _ _ = function true -> str "|- " ++ spc () ++ str "*" | _ -> str "|-" - -ARGUMENT EXTEND inconcl - TYPED AS bool - PRINTED BY pr_in_concl -| [ "|-" "*" ] -> [ true ] -| [ "|-" ] -> [ false ] -END - - - -ARGUMENT EXTEND in_arg_hyp - PRINTED BY pr_in_arg_hyp_typed - RAW_TYPED AS var list option * bool - RAW_PRINTED BY pr_in_arg_hyp - GLOB_TYPED AS var list option * bool - GLOB_PRINTED BY pr_in_arg_hyp -| [ "in" "*" ] -> [(None,true)] -| [ "in" "*" inconcl_opt(b) ] -> [let onconcl = match b with Some b -> b | None -> true in (None,onconcl)] -| [ "in" comma_var_l(l) inconcl_opt(b) ] -> [ let onconcl = match b with Some b -> b | None -> false in - Some l, onconcl - ] -| [ ] -> [ (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= - Option.map - (fun l -> - List.map - (fun id -> ( (all_occurrences_expr,trad_id id),InHyp)) - l - ) - hyps; - Tacexpr.concl_occs = if concl then all_occurrences_expr else no_occurrences_expr} - - -let raw_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause snd -let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x) - - -(* spiwack argument for the commands of the retroknowledge *) - -let (wit_r_nat_field, globwit_r_nat_field, rawwit_r_nat_field) = - Genarg.create_arg None "r_nat_field" -let (wit_r_n_field, globwit_r_n_field, rawwit_r_n_field) = - Genarg.create_arg None "r_n_field" -let (wit_r_int31_field, globwit_r_int31_field, rawwit_r_int31_field) = - Genarg.create_arg None "r_int31_field" -let (wit_r_field, globwit_r_field, rawwit_r_field) = - Genarg.create_arg None "r_field" - (* spiwack: the print functions are incomplete, but I don't know what they are used for *) -let pr_r_nat_field _ _ _ natf = +let pr_r_nat_field natf = str "nat " ++ match natf with | Retroknowledge.NatType -> str "type" | Retroknowledge.NatPlus -> str "plus" | Retroknowledge.NatTimes -> str "times" -let pr_r_n_field _ _ _ nf = +let pr_r_n_field nf = str "binary N " ++ match nf with | Retroknowledge.NPositive -> str "positive" @@ -307,7 +226,7 @@ let pr_r_n_field _ _ _ nf = | Retroknowledge.NPlus -> str "plus" | Retroknowledge.NTimes -> str "times" -let pr_r_int31_field _ _ _ i31f = +let pr_r_int31_field i31f = str "int31 " ++ match i31f with | Retroknowledge.Int31Bits -> str "bits" @@ -320,16 +239,15 @@ let pr_r_int31_field _ _ _ i31f = | Retroknowledge.Int31Times -> str "times" | _ -> assert false -let pr_retroknowledge_field _ _ _ f = +let pr_retroknowledge_field f = match f with (* | Retroknowledge.KEq -> str "equality" | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf | Retroknowledge.KN nf -> pr_r_n_field () () () nf *) - | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field () () () i31f) ++ + | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++ str "in " ++ str group -ARGUMENT EXTEND retroknowledge_nat -TYPED AS r_nat_field +VERNAC ARGUMENT EXTEND retroknowledge_nat PRINTED BY pr_r_nat_field | [ "nat" "type" ] -> [ Retroknowledge.NatType ] | [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ] @@ -337,8 +255,7 @@ PRINTED BY pr_r_nat_field END -ARGUMENT EXTEND retroknowledge_binary_n -TYPED AS r_n_field +VERNAC ARGUMENT EXTEND retroknowledge_binary_n PRINTED BY pr_r_n_field | [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] | [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] @@ -350,8 +267,7 @@ PRINTED BY pr_r_n_field | [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ] END -ARGUMENT EXTEND retroknowledge_int31 -TYPED AS r_int31_field +VERNAC ARGUMENT EXTEND retroknowledge_int31 PRINTED BY pr_r_int31_field | [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] | [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] @@ -369,15 +285,17 @@ PRINTED BY pr_r_int31_field | [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ] | [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ] | [ "int31" "div" ] -> [ Retroknowledge.Int31Div ] +| [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ] | [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ] | [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ] | [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ] | [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ] - +| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ] +| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ] +| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ] END -ARGUMENT EXTEND retroknowledge_field -TYPED AS r_field +VERNAC ARGUMENT EXTEND retroknowledge_field PRINTED BY pr_retroknowledge_field (*| [ "equality" ] -> [ Retroknowledge.KEq ] | [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index 8a0ae066..ef084e9d 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -1,55 +1,54 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds 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 wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type +val pr_occurrences : int list or_var -> Pp.std_ppcmds +val occurrences_of : int list -> Locus.occurrences + +val wit_glob : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Tacinterp.interp_sign * glob_constr) Genarg.genarg_type + +val wit_lglob : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Tacinterp.interp_sign * glob_constr) Genarg.genarg_type -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 +val lglob : constr_expr Pcoq.Gram.entry -type 'id gen_place= ('id * hyp_location_flag,unit) location +type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location -type loc_place = identifier Util.located gen_place -type place = identifier gen_place +type loc_place = Id.t Loc.located gen_place +type place = Id.t gen_place -val rawwit_hloc : loc_place raw_abstract_argument_type -val wit_hloc : place typed_abstract_argument_type +val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type 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 -val globwit_in_arg_hyp : (Names.identifier Util.located list option * bool) glob_abstract_argument_type -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 -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 wit_by_arg_tac : + (raw_tactic_expr option, + glob_tactic_expr option, + glob_tactic_expr option) Genarg.genarg_type + val pr_by_arg_tac : (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> raw_tactic_expr option -> Pp.std_ppcmds @@ -58,5 +57,4 @@ val pr_by_arg_tac : (** Spiwack: Primitive for retroknowledge registration *) 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 +val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 6fd95f16..f3482c31 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -1,26 +1,29 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ admit_as_an_axiom ] END - - -let classes_dirpath = - make_dirpath (List.map id_of_string ["Classes";"Coq"]) - -let init_setoid () = - if Libnames.is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () - else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] - - -let occurrences_of occs = - let loccs = match occs with - | n::_ as nl when n < 0 -> (false,List.map (fun n -> ArgArg (abs n)) nl) - | nl -> - if List.exists (fun n -> n < 0) nl then - error "Illegal negative occurrence number."; - (true, List.map (fun n -> (ArgArg n)) nl) - in - init_setoid (); - {onhyps = Some []; concl_occs =loccs} - -let replace_in_clause_maybe_by (sigma1,c1) c2 cl tac = - Refiner.tclWITHHOLES false +let replace_in_clause_maybe_by (sigma,c1) c2 cl tac = + Proofview.Unsafe.tclEVARS sigma <*> (replace_in_clause_maybe_by c1 c2 cl) - sigma1 (Option.map Tacinterp.eval_tactic tac) -let replace_multi_term dir_opt (sigma,c) in_hyp = - Refiner.tclWITHHOLES false - (replace_multi_term dir_opt c) - sigma - (glob_in_arg_hyp_to_clause in_hyp) +let replace_term dir_opt (sigma,c) cl = + Proofview.Unsafe.tclEVARS sigma <*> + (replace_term dir_opt c) cl TACTIC EXTEND replace - ["replace" open_constr(c1) "with" constr(c2) in_arg_hyp(in_hyp) by_arg_tac(tac) ] --> [ replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp) tac ] -END - -TACTIC EXTEND replace_at - ["replace" open_constr(c1) "with" constr(c2) "at" occurrences(occs) by_arg_tac(tac) ] --> [ replace_in_clause_maybe_by c1 c2 (occurrences_of occs) tac ] + ["replace" open_constr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] +-> [ replace_in_clause_maybe_by c1 c2 cl tac ] END - TACTIC EXTEND replace_term_left - [ "replace" "->" open_constr(c) in_arg_hyp(in_hyp) ] - -> [ replace_multi_term (Some true) c in_hyp] + [ "replace" "->" open_constr(c) clause(cl) ] + -> [ replace_term (Some true) c cl ] END TACTIC EXTEND replace_term_right - [ "replace" "<-" open_constr(c) in_arg_hyp(in_hyp) ] - -> [replace_multi_term (Some false) c in_hyp] + [ "replace" "<-" open_constr(c) clause(cl) ] + -> [ replace_term (Some false) c cl ] END TACTIC EXTEND replace_term - [ "replace" open_constr(c) in_arg_hyp(in_hyp) ] - -> [ replace_multi_term None c in_hyp ] + [ "replace" open_constr(c) clause(cl) ] + -> [ replace_term None c cl ] END let induction_arg_of_quantified_hyp = function - | AnonHyp n -> ElimOnAnonHyp n - | NamedHyp id -> ElimOnIdent (Util.dummy_loc,id) + | AnonHyp n -> None,ElimOnAnonHyp n + | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id) (* Versions *_main must come first!! so that "1" is interpreted as a ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a ElimOnIdent and not as "constr" *) let elimOnConstrWithHoles tac with_evars c = - Refiner.tclWITHHOLES with_evars (tac with_evars) - c.sigma (Some (ElimOnConstr c.it)) + Tacticals.New.tclWITHHOLES with_evars (tac with_evars) + c.sigma (Some (None,ElimOnConstr c.it)) TACTIC EXTEND simplify_eq_main | [ "simplify_eq" constr_with_bindings(c) ] -> @@ -120,9 +93,11 @@ TACTIC EXTEND esimplify_eq [ dEq true (Some (induction_arg_of_quantified_hyp h)) ] END +let discr_main c = elimOnConstrWithHoles discr_tac false c + TACTIC EXTEND discriminate_main | [ "discriminate" constr_with_bindings(c) ] -> - [ elimOnConstrWithHoles discr_tac false c ] + [ discr_main c ] END TACTIC EXTEND discriminate | [ "discriminate" ] -> [ discr_tac false None ] @@ -139,49 +114,55 @@ TACTIC EXTEND ediscriminate [ discr_tac true (Some (induction_arg_of_quantified_hyp h)) ] END -let h_discrHyp id gl = - h_discriminate_main {it = Term.mkVar id,NoBindings; sigma = Refiner.project gl} gl +open Proofview.Notations +let discrHyp id = + Proofview.tclEVARMAP >>= fun sigma -> + discr_main {it = Term.mkVar id,NoBindings; sigma = sigma;} + +let injection_main c = + elimOnConstrWithHoles (injClause None) false c TACTIC EXTEND injection_main | [ "injection" constr_with_bindings(c) ] -> - [ elimOnConstrWithHoles (injClause []) false c ] + [ injection_main c ] END TACTIC EXTEND injection -| [ "injection" ] -> [ injClause [] false None ] +| [ "injection" ] -> [ injClause None false None ] | [ "injection" quantified_hypothesis(h) ] -> - [ injClause [] false (Some (induction_arg_of_quantified_hyp h)) ] + [ injClause None false (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND einjection_main | [ "einjection" constr_with_bindings(c) ] -> - [ elimOnConstrWithHoles (injClause []) true c ] + [ elimOnConstrWithHoles (injClause None) true c ] END TACTIC EXTEND einjection -| [ "einjection" ] -> [ injClause [] true None ] -| [ "einjection" quantified_hypothesis(h) ] -> [ injClause [] true (Some (induction_arg_of_quantified_hyp h)) ] +| [ "einjection" ] -> [ injClause None true None ] +| [ "einjection" quantified_hypothesis(h) ] -> [ injClause None true (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND injection_as_main | [ "injection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> - [ elimOnConstrWithHoles (injClause ipat) false c ] + [ elimOnConstrWithHoles (injClause (Some ipat)) false c ] END TACTIC EXTEND injection_as | [ "injection" "as" simple_intropattern_list(ipat)] -> - [ injClause ipat false None ] + [ injClause (Some ipat) false None ] | [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] -> - [ injClause ipat false (Some (induction_arg_of_quantified_hyp h)) ] + [ injClause (Some ipat) false (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND einjection_as_main | [ "einjection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> - [ elimOnConstrWithHoles (injClause ipat) true c ] + [ elimOnConstrWithHoles (injClause (Some ipat)) true c ] END TACTIC EXTEND einjection_as | [ "einjection" "as" simple_intropattern_list(ipat)] -> - [ injClause ipat true None ] + [ injClause (Some ipat) true None ] | [ "einjection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] -> - [ injClause ipat true (Some (induction_arg_of_quantified_hyp h)) ] + [ injClause (Some ipat) true (Some (induction_arg_of_quantified_hyp h)) ] END -let h_injHyp id gl = - h_injection_main { it = Term.mkVar id,NoBindings; sigma = Refiner.project gl } gl +let injHyp id = + Proofview.tclEVARMAP >>= fun sigma -> + injection_main { it = Term.mkVar id,NoBindings; sigma = sigma; } TACTIC EXTEND dependent_rewrite | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] @@ -189,12 +170,27 @@ TACTIC EXTEND dependent_rewrite -> [ rewriteInHyp b c id ] END +(** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to + "replace u with t" or "enough (t=u) as <-" and + "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) + TACTIC EXTEND cut_rewrite | [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] | [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] -> [ cutRewriteInHyp b eqn id ] END +(**********************************************************************) +(* Decompose *) + +TACTIC EXTEND decompose_sum +| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ] +END + +TACTIC EXTEND decompose_record +| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ] +END + (**********************************************************************) (* Contradiction *) @@ -206,7 +202,7 @@ END let onSomeWithHoles tac = function | None -> tac None - | Some c -> Refiner.tclWITHHOLES false tac c.sigma (Some c.it) + | Some c -> Proofview.Unsafe.tclEVARS c.sigma <*> tac (Some c.it) TACTIC EXTEND contradiction [ "contradiction" constr_with_bindings_opt(c) ] -> @@ -230,22 +226,19 @@ ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_stri 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) ] -> +| [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> + [ auto_multi_rewrite l ( cl) ] +| [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> [ - let cl = glob_in_arg_hyp_to_clause cl in auto_multi_rewrite_with (Tacinterp.eval_tactic t) l cl - ] END TACTIC EXTEND autorewrite_star -| [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) ] -> - [ 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 (Tacinterp.eval_tactic t) l cl ] +| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> + [ auto_multi_rewrite ~conds:AllMatches l cl ] +| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> + [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.eval_tactic t) l cl ] END (**********************************************************************) @@ -253,15 +246,8 @@ 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 true (c,NoBindings)) sigma true - -let occurrences_of = function - | n::_ as nl when n < 0 -> (false,List.map abs nl) - | nl -> - if List.exists (fun n -> n < 0) nl then - error "Illegal negative occurrence number."; - (true,nl) + Proofview.Unsafe.tclEVARS sigma <*> + general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true TACTIC EXTEND rewrite_star | [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> @@ -269,45 +255,62 @@ 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 Termops.all_occurrences c tac ] + [ rewrite_star (Some id) o Locus.AllOccurrences 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 Termops.all_occurrences c tac ] + [ rewrite_star None o Locus.AllOccurrences c tac ] END (**********************************************************************) (* Hint Rewrite *) -let add_rewrite_hint name ort t lcsr = +let add_rewrite_hint bases ort t lcsr = let env = Global.env() and sigma = Evd.empty in - let f c = Topconstr.constr_loc c, Constrintern.interp_constr sigma env c, ort, t in - add_rew_rules name (List.map f lcsr) - -VERNAC COMMAND EXTEND HintRewrite - [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident(b) ] -> - [ add_rewrite_hint b o (Tacexpr.TacId []) l ] + let poly = Flags.is_universe_polymorphism () in + let f ce = + let c, ctx = Constrintern.interp_constr env sigma ce in + let ctx = + if poly then + Evd.evar_universe_context_set ctx + else + let cstrs = Evd.evar_universe_context_constraints ctx in + (Global.add_constraints cstrs; Univ.ContextSet.empty) + in + Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in + let eqs = List.map f lcsr in + let add_hints base = add_rew_rules base eqs in + List.iter add_hints bases + +let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater + +VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint + [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + [ add_rewrite_hint bl o None l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) - ":" preident(b) ] -> - [ add_rewrite_hint b o t l ] + ":" preident_list(bl) ] -> + [ add_rewrite_hint bl o (Some t) l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - [ add_rewrite_hint "core" o (Tacexpr.TacId []) l ] + [ add_rewrite_hint ["core"] o None l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - [ add_rewrite_hint "core" o t l ] + [ add_rewrite_hint ["core"] o (Some t) l ] END (**********************************************************************) (* Hint Resolve *) open Term +open Vars open Coqlib -let project_hint pri l2r c = +let project_hint pri l2r r = + let gr = Smartlocate.global_with_alias r in let env = Global.env() in - let c = Constrintern.interp_constr Evd.empty env c in - let t = Retyping.get_type_of env Evd.empty c in + let sigma = Evd.from_env env in + let sigma, c = Evd.fresh_global env sigma gr in + let t = Retyping.get_type_of env sigma c in let t = - Tacred.reduce_to_quantified_ref env Evd.empty (Lazy.force coq_iff_ref) t in + Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in let sign,ccl = decompose_prod_assum t in let (a,b) = match snd (decompose_app ccl) with | [a;b] -> (a,b) @@ -317,82 +320,91 @@ 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,Auto.PathAny,c) + let id = + Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) + in + let ctx = Evd.universe_context_set sigma in + let c = Declare.declare_definition ~internal:Declare.KernelSilent id (c,ctx) in + (pri,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) let add_hints_iff l2r lc n bl = - Auto.add_hints true bl - (Auto.HintsResolveEntry (List.map (project_hint n l2r) lc)) + Hints.add_hints true bl + (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc)) -VERNAC COMMAND EXTEND HintResolveIffLR - [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n) +VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF + [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ":" preident_list(bl) ] -> [ add_hints_iff true lc n bl ] -| [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n) ] -> +| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> [ add_hints_iff true lc n ["core"] ] END -VERNAC COMMAND EXTEND HintResolveIffRL - [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n) +VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF + [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ":" preident_list(bl) ] -> [ add_hints_iff false lc n bl ] -| [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n) ] -> +| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> [ add_hints_iff false lc n ["core"] ] END (**********************************************************************) (* Refine *) -open Refine +let refine_tac {Glob_term.closure=closure;term=term} = + Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let flags = Pretyping.all_no_fail_flags in + let tycon = Pretyping.OfType concl in + let lvar = { Pretyping.empty_lvar with + Pretyping.ltac_constrs = closure.Glob_term.typed; + Pretyping.ltac_uconstrs = closure.Glob_term.untyped; + Pretyping.ltac_idents = closure.Glob_term.idents; + } in + let update evd = Pretyping.understand_ltac flags env evd lvar tycon term in + Tactics.New.refine ~unsafe:false update + end TACTIC EXTEND refine - [ "refine" casted_open_constr(c) ] -> [ refine c ] + [ "refine" uconstr(c) ] -> [ refine_tac c ] END -let refine_tac = h_refine - (**********************************************************************) (* Inversion lemmas (Leminv) *) open Inv open Leminv -VERNAC COMMAND EXTEND DeriveInversionClear - [ "Derive" "Inversion_clear" ident(na) hyp(id) ] - -> [ inversion_lemma_from_goal 1 na id Term.prop_sort false inv_clear_tac ] - -| [ "Derive" "Inversion_clear" natural(n) ident(na) hyp(id) ] - -> [ inversion_lemma_from_goal n na id Term.prop_sort false inv_clear_tac ] +let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater +VERNAC COMMAND EXTEND DeriveInversionClear | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] -> [ 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 (Glob_term.GProp Term.Null) false inv_clear_tac ] +| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] + -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ] END open Term -open Glob_term VERNAC COMMAND EXTEND DeriveInversion | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] -> [ add_inversion_lemma_exn na c s false inv_tac ] -| [ "Derive" "Inversion" ident(na) "with" constr(c) ] - -> [ 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 ] - -| [ "Derive" "Inversion" natural(n) ident(na) hyp(id) ] - -> [ inversion_lemma_from_goal n na id Term.prop_sort false inv_tac ] +| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] + -> [ add_inversion_lemma_exn na c GProp false inv_tac ] END VERNAC COMMAND EXTEND DeriveDependentInversion | [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] -> [ add_inversion_lemma_exn na c s true dinv_tac ] - END +END VERNAC COMMAND EXTEND DeriveDependentInversionClear | [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] END @@ -401,14 +413,14 @@ END TACTIC EXTEND subst | [ "subst" ne_var_list(l) ] -> [ subst l ] -| [ "subst" ] -> [ fun gl -> subst_all gl ] +| [ "subst" ] -> [ subst_all () ] END let simple_subst_tactic_flags = { only_leibniz = true; rewrite_dependent_proof = false } TACTIC EXTEND simple_subst -| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags ] +| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ] END open Evar_tactics @@ -416,29 +428,28 @@ open Evar_tactics (**********************************************************************) (* Evar creation *) +(* TODO: add support for some test similar to g_constr.name_colon so that + expressions like "evar (list A)" do not raise a syntax error *) TACTIC EXTEND evar [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ] | [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ] END -open Tacexpr open Tacticals TACTIC EXTEND instantiate - [ "instantiate" "(" integer(i) ":=" glob(c) ")" hloc(hl) ] -> - [instantiate i c hl ] -| [ "instantiate" ] -> [ tclNORMEVAR ] + [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> + [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ] +| [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] -> + [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ] +| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ] END - (**********************************************************************) (** Nijmegen "step" tactic for setoid rewriting *) open Tactics -open Tactics -open Libnames open Glob_term -open Summary open Libobject open Lib @@ -447,8 +458,8 @@ open Lib x R y -> x == z -> z R y (in the left table) *) -let transitivity_right_table = ref [] -let transitivity_left_table = ref [] +let transitivity_right_table = Summary.ref [] ~name:"transitivity-steps-r" +let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l" (* [step] tries to apply a rewriting lemma; then apply [tac] intended to complete to proof of the last hypothesis (assumed to state an equality) *) @@ -456,12 +467,12 @@ let transitivity_left_table = ref [] let step left x tac = let l = List.map (fun lem -> - tclTHENLAST - (apply_with_bindings (lem, ImplicitBindings [x])) + Tacticals.New.tclTHENLAST + (apply_with_bindings (lem, ImplicitBindings [x])) tac) !(if left then transitivity_left_table else transitivity_right_table) in - tclFIRST l + Tacticals.New.tclFIRST l (* Main function to push lemmas in persistent environment *) @@ -476,59 +487,43 @@ let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) 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); + open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o); subst_function = subst_transitivity_lemma; classify_function = (fun o -> Substitute o) } -(* Synchronisation with reset *) - -let freeze () = !transitivity_left_table, !transitivity_right_table - -let unfreeze (l,r) = - transitivity_left_table := l; - transitivity_right_table := r - -let init () = - transitivity_left_table := []; - transitivity_right_table := [] - -let _ = - declare_summary "transitivity-steps" - { freeze_function = freeze; - unfreeze_function = unfreeze; - init_function = init } - (* Main entry points *) let add_transitivity_lemma left lem = - let lem' = Constrintern.interp_constr Evd.empty (Global.env ()) lem in + let lem',ctx (*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty lem in add_anonymous_leaf (inTransitivity (left,lem')) (* Vernacular syntax *) TACTIC EXTEND stepl | ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.eval_tactic tac) ] -| ["stepl" constr(c) ] -> [ step true c tclIDTAC ] +| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] END TACTIC EXTEND stepr | ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.eval_tactic tac) ] -| ["stepr" constr(c) ] -> [ step false c tclIDTAC ] +| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] END -VERNAC COMMAND EXTEND AddStepl +VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF | [ "Declare" "Left" "Step" constr(t) ] -> [ add_transitivity_lemma true t ] END -VERNAC COMMAND EXTEND AddStepr +VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF | [ "Declare" "Right" "Step" constr(t) ] -> [ add_transitivity_lemma false t ] END -VERNAC COMMAND EXTEND ImplicitTactic +VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF | [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ Pfedit.declare_implicit_tactic (Tacinterp.interp tac) ] +| [ "Clear" "Implicit" "Tactic" ] -> + [ Pfedit.clear_implicit_tactic () ] END @@ -537,10 +532,10 @@ END (**********************************************************************) (*spiwack : Vernac commands for retroknowledge *) -VERNAC COMMAND EXTEND RetroknowledgeRegister +VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> - [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in - let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in + [ let tc,ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in + let tb,ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in Global.register f tc tb ] END @@ -567,7 +562,7 @@ END during dependent induction. For internal use. *) TACTIC EXTEND specialize_eqs -[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ] +[ "specialize_eqs" hyp(id) ] -> [ Proofview.V82.tactic (specialize_eqs id) ] END (**********************************************************************) @@ -579,26 +574,36 @@ END (**********************************************************************) let subst_var_with_hole occ tid t = - let occref = if occ > 0 then ref occ else Termops.error_invalid_occurrence [occ] in + let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in let locref = ref 0 in let rec substrec = function | GVar (_,id) as x -> - if id = tid - then (decr occref; if !occref = 0 then x - else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true)))) + if Id.equal id tid + then + (decr occref; + if Int.equal !occref 0 then x + else + (incr locref; + GHole (Loc.make_loc (!locref,0), + Evar_kinds.QuestionMark(Evar_kinds.Define true), + Misctypes.IntroAnonymous, None))) else x | c -> map_glob_constr_left_to_right substrec c in let t' = substrec t in - if !occref > 0 then Termops.error_invalid_occurrence [occ] else t' + if !occref > 0 then Find_subterm.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 - | GHole (_,Evd.QuestionMark(Evd.Define true)) -> - decr occref; if !occref = 0 then tc - else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true))) + | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) -> + decr occref; + if Int.equal !occref 0 then tc + else + (incr locref; + GHole (Loc.make_loc (!locref,0), + Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s)) | c -> map_glob_constr_left_to_right substrec c in substrec t @@ -606,31 +611,38 @@ let subst_hole_with_term occ tc t = open Tacmach let out_arg = function - | ArgVar _ -> anomaly "Unevaluated or_var variable" + | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable") | ArgArg x -> x -let hResolve id c occ t gl = - let sigma = project gl in - let env = Termops.clear_named_body id (pf_env gl) in +let hResolve id c occ t = + Proofview.Goal.nf_enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Termops.clear_named_body id (Proofview.Goal.env gl) in + let concl = Proofview.Goal.concl 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 c_raw = Detyping.detype true env_ids env sigma c in + let t_raw = Detyping.detype true env_ids env sigma t in let rec resolve_hole t_hole = try - Pretyping.Default.understand sigma env t_hole - with - | Loc.Exc_located (loc,Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _)) -> - resolve_hole (subst_hole_with_term (fst (unloc loc)) c_raw t_hole) + Pretyping.understand env sigma t_hole + with + | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e -> + let (e, info) = Errors.push e in + let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in + resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) in - let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in + let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in + let sigma = Evd.merge_universe_context sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in - change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl)) gl + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) + end -let hResolve_auto id c t gl = +let hResolve_auto id c t = let rec resolve_auto n = try - hResolve id c n t gl + hResolve id c n t with | UserError _ as e -> raise e | e when Errors.noncritical e -> resolve_auto (n+1) @@ -646,18 +658,18 @@ END hget_evar *) -open Evar_refiner -open Sign - -let hget_evar n gl = - let sigma = project gl in - let evl = evar_list sigma (pf_concl gl) in +let hget_evar n = + Proofview.Goal.nf_enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let evl = evar_list concl in if List.length evl < n then error "Not enough uninstantiated existential variables."; if n <= 0 then error "Incorrect existential variable index."; let ev = List.nth evl (n-1) in let ev_type = existential_type sigma ev in - change_in_concl None (mkLetIn (Anonymous,mkEvar ev,ev_type,pf_concl gl)) gl + change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) + end TACTIC EXTEND hget_evar | [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ] @@ -673,12 +685,15 @@ END (* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) (**********************************************************************) -exception Found of tactic +exception Found of unit Proofview.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 rewrite_except h = + Proofview.Goal.nf_enter begin fun gl -> + let hyps = Tacmach.New.pf_ids_of_hyps gl in + Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else + Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) + hyps + end let refl_equal = @@ -691,31 +706,39 @@ let refl_equal = (* 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 [ +let mkCaseEq a : unit Proofview.tactic = + Proofview.Goal.nf_enter begin fun gl -> + let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_type_of g a) gl in + Tacticals.New.tclTHENLIST + [Proofview.V82.tactic (Tactics.Simple.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]); + Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + change_concl + (snd (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl)) + end; + simplest_case a] + end + + +let case_eq_intros_rewrite x = + Proofview.Goal.nf_enter begin fun gl -> + let n = nb_prod (Proofview.Goal.concl gl) in + (* Pp.msgnl (Printer.pr_lconstr x); *) + Tacticals.New.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 + Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let hyps = Tacmach.New.pf_ids_of_hyps gl in + let n' = nb_prod concl in + let h = Tacmach.New.of_old (fun g -> fresh_id hyps (Id.of_string "heq") g) gl in + Tacticals.New.tclTHENLIST [ + Tacticals.New.tclDO (n'-n-1) intro; + introduction h; + rewrite_except h] + end + ] + end let rec find_a_destructable_match t = match kind_of_term t with @@ -724,40 +747,52 @@ let rec find_a_destructable_match t = (* TODO check there is no rel n. *) raise (Found (Tacinterp.eval_tactic(<:tactic>))) else - let _ = Pp.msgnl (Printer.pr_lconstr x) in + (* 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" + Proofview.tclZERO (UserError ("", str"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 +let destauto_in id = + Proofview.Goal.nf_enter begin fun gl -> + let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_type_of g (mkVar id)) gl in +(* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) +(* Pp.msgnl (Printer.pr_lconstr (ctype)); *) + destauto ctype + end TACTIC EXTEND destauto -| [ "destauto" ] -> [ (fun g -> destauto (Tacmach.pf_concl g) g) ] +| [ "destauto" ] -> [ Proofview.Goal.nf_enter (fun gl -> destauto (Proofview.Goal.concl gl)) ] | [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] END (* ********************************************************************* *) +let eq_constr x y = + Proofview.Goal.enter (fun gl -> + let evd = Proofview.Goal.sigma gl in + if Evd.eq_constr_univs_test evd x y then Proofview.tclUNIT () + else Tacticals.New.tclFAIL 0 (str "Not equal")) + TACTIC EXTEND constr_eq -| [ "constr_eq" constr(x) constr(y) ] -> [ - if eq_constr x y then tclIDTAC else tclFAIL 0 (str "Not equal") ] +| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] +END + +TACTIC EXTEND constr_eq_nounivs +| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ + if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] END TACTIC EXTEND is_evar | [ "is_evar" constr(x) ] -> [ match kind_of_term x with - | Evar _ -> tclIDTAC - | _ -> tclFAIL 0 (str "Not an evar") + | Evar _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") ] END @@ -776,28 +811,36 @@ let rec has_evar x = has_evar t1 || has_evar t2 || has_evar_array ts | Fix ((_, tr)) | CoFix ((_, tr)) -> has_evar_prec tr + | Proj (p, c) -> has_evar c and has_evar_array x = - array_exists has_evar x + Array.exists has_evar x and has_evar_prec (_, ts1, ts2) = - array_exists has_evar ts1 || array_exists has_evar ts2 + Array.exists has_evar ts1 || Array.exists has_evar ts2 TACTIC EXTEND has_evar | [ "has_evar" constr(x) ] -> - [ if has_evar x then tclIDTAC else tclFAIL 0 (str "No evars") ] + [ if has_evar x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") ] END TACTIC EXTEND is_hyp | [ "is_var" constr(x) ] -> [ match kind_of_term x with - | Var _ -> tclIDTAC - | _ -> tclFAIL 0 (str "Not a variable or hypothesis") ] + | Var _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ] END TACTIC EXTEND is_fix | [ "is_fix" constr(x) ] -> [ match kind_of_term x with - | Fix _ -> Tacticals.tclIDTAC - | _ -> Tacticals.tclFAIL 0 (Pp.str "not a fix definition") ] + | Fix _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ] +END;; + +TACTIC EXTEND is_cofix +| [ "is_cofix" constr(x) ] -> + [ match kind_of_term x with + | CoFix _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ] END;; (* Command to grab the evars left unresolved at the end of a proof. *) @@ -805,8 +848,169 @@ END;; the semantics of the LCF-style tactics, hence with the classic tactic mode. *) VERNAC COMMAND EXTEND GrabEvars -[ "Grab" "Existential" "Variables" ] -> - [ let p = Proof_global.give_me_the_proof () in - Proof.V82.grab_evars p; - Flags.if_verbose (fun () -> Pp.msg (Printer.pr_open_subgoals ())) () ] +[ "Grab" "Existential" "Variables" ] + => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] + -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] +END + +(* Shelves all the goals under focus. *) +TACTIC EXTEND shelve +| [ "shelve" ] -> + [ Proofview.shelve ] +END + +(* Shelves the unifiable goals under focus, i.e. the goals which + appear in other goals under focus (the unfocused goals are not + considered). *) +TACTIC EXTEND shelve_unifiable +| [ "shelve_unifiable" ] -> + [ Proofview.shelve_unifiable ] +END + +(* Command to add every unshelved variables to the focus *) +VERNAC COMMAND EXTEND Unshelve +[ "Unshelve" ] + => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] + -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] +END + +(* Gives up on the goals under focus: the goals are considered solved, + but the proof cannot be closed until the user goes back and solve + these goals. *) +TACTIC EXTEND give_up +| [ "give_up" ] -> + [ Proofview.give_up ] +END + +(* cycles [n] goals *) +TACTIC EXTEND cycle +| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle (out_arg n) ] +END + +(* swaps goals number [i] and [j] *) +TACTIC EXTEND swap +| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap (out_arg i) (out_arg j) ] +END + +(* reverses the list of focused goals *) +TACTIC EXTEND revgoals +| [ "revgoals" ] -> [ Proofview.revgoals ] +END + + +type cmp = + | Eq + | Lt | Le + | Gt | Ge + +type 'i test = + | Test of cmp * 'i * 'i + +let wit_cmp : (cmp,cmp,cmp) Genarg.genarg_type = Genarg.make0 None "cmp" +let wit_test : (int or_var test,int or_var test,int test) Genarg.genarg_type = + Genarg.make0 None "tactest" + +let pr_cmp = function + | Eq -> Pp.str"=" + | Lt -> Pp.str"<" + | Le -> Pp.str"<=" + | Gt -> Pp.str">" + | Ge -> Pp.str">=" + +let pr_cmp' _prc _prlc _prt = pr_cmp + +let pr_test_gen f (Test(c,x,y)) = + Pp.(f x ++ pr_cmp c ++ f y) + +let pr_test = pr_test_gen (Pptactic.pr_or_var Pp.int) + +let pr_test' _prc _prlc _prt = pr_test + +let pr_itest = pr_test_gen Pp.int + +let pr_itest' _prc _prlc _prt = pr_itest + + + +ARGUMENT EXTEND comparison TYPED AS cmp PRINTED BY pr_cmp' +| [ "=" ] -> [ Eq ] +| [ "<" ] -> [ Lt ] +| [ "<=" ] -> [ Le ] +| [ ">" ] -> [ Gt ] +| [ ">=" ] -> [ Ge ] + END + +let interp_test ist gls = function + | Test (c,x,y) -> + project gls , + Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y) + +ARGUMENT EXTEND test + PRINTED BY pr_itest' + INTERPRETED BY interp_test + RAW_TYPED AS test + RAW_PRINTED BY pr_test' + GLOB_TYPED AS test + GLOB_PRINTED BY pr_test' +| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] +END + +let interp_cmp = function + | Eq -> Int.equal + | Lt -> ((<):int->int->bool) + | Le -> ((<=):int->int->bool) + | Gt -> ((>):int->int->bool) + | Ge -> ((>=):int->int->bool) + +let run_test = function + | Test(c,x,y) -> interp_cmp c x y + +let guard tst = + if run_test tst then + Proofview.tclUNIT () + else + let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in + Proofview.tclZERO (Errors.UserError("guard",msg)) + + +TACTIC EXTEND guard +| [ "guard" test(tst) ] -> [ guard tst ] +END + +let decompose l c = + Proofview.Goal.enter begin fun gl -> + let to_ind c = + if isInd c then Univ.out_punivs (destInd c) + else error "not an inductive type" + in + let l = List.map to_ind l in + Elim.h_decompose l c + end + +TACTIC EXTEND decompose +| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] +END + +(** library/keys *) + +VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF +| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ + let it c = snd (Constrintern.interp_open_constr (Global.env ()) Evd.empty c) in + let k1 = Keys.constr_key (it c) in + let k2 = Keys.constr_key (it c') in + match k1, k2 with + | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 + | _ -> () ] +END + +VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY +| [ "Print" "Equivalent" "Keys" ] -> [ msg_info (Keys.pr_keys Printer.pr_global) ] +END + + +VERNAC COMMAND EXTEND OptimizeProof +| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] -> + [ Proof_global.compact_the_proof () ] +| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> + [ Gc.compact () ] END diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli index 934d94fc..72c2679c 100644 --- a/tactics/extratactics.mli +++ b/tactics/extratactics.mli @@ -1,16 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit Proofview.tactic +val injHyp : Names.Id.t -> unit Proofview.tactic -val h_discrHyp : Names.identifier -> tactic -val h_injHyp : Names.identifier -> tactic +(* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) -val refine_tac : Evd.open_constr -> tactic - -val onSomeWithHoles : ('a option -> tactic) -> 'a Evd.sigma option -> tactic +val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Evd.sigma option -> unit Proofview.tactic diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml new file mode 100644 index 00000000..fea0432a --- /dev/null +++ b/tactics/ftactic.ml @@ -0,0 +1,86 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* b t) : b t = m >>= function +| Uniform x -> f x +| Depends l -> + let f arg = f arg >>= function + | Uniform x -> + (** We dispatch the uniform result on each goal under focus, as we know + that the [m] argument was actually dependent. *) + Proofview.Goal.goals >>= fun l -> + let ans = List.map (fun _ -> x) l in + Proofview.tclUNIT ans + | Depends l -> Proofview.tclUNIT l + in + Proofview.tclDISPATCHL (List.map f l) >>= fun l -> + Proofview.tclUNIT (Depends (List.concat l)) + +let nf_enter f = + bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l)) + (fun gl -> + gl >>= fun gl -> + Proofview.Goal.normalize gl >>= fun nfgl -> + Proofview.V82.wrap_exceptions (fun () -> f nfgl)) + +let enter f = + bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l)) + (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f gl)) + +let with_env t = + t >>= function + | Uniform a -> + Proofview.tclENV >>= fun env -> Proofview.tclUNIT (Uniform (env,a)) + | Depends l -> + Proofview.Goal.goals >>= fun gs -> + Proofview.Monad.(List.map (map Proofview.Goal.env) gs) >>= fun envs -> + Proofview.tclUNIT (Depends (List.combine envs l)) + +let lift (type a) (t:a Proofview.tactic) : a t = + Proofview.tclBIND t (fun x -> Proofview.tclUNIT (Uniform x)) + +(** If the tactic returns unit, we can focus on the goals if necessary. *) +let run m k = m >>= function +| Uniform v -> k v +| Depends l -> + let tacs = List.map k l in + Proofview.tclDISPATCH tacs + +let (>>=) = bind + +let (<*>) = fun m n -> bind m (fun () -> n) + +module Self = +struct + type 'a t = 'a focus Proofview.tactic + let return = return + let (>>=) = bind + let (>>) = (<*>) + let map f x = x >>= fun a -> return (f a) +end + +module Ftac = Monad.Make(Self) +module List = Ftac.List + +let debug_prompt = Tactic_debug.debug_prompt diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli new file mode 100644 index 00000000..48351567 --- /dev/null +++ b/tactics/ftactic.mli @@ -0,0 +1,67 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a t +(** The unit of the monad. *) + +val bind : 'a t -> ('a -> 'b t) -> 'b t +(** The bind of the monad. *) + +(** {5 Operations} *) + +val lift : 'a Proofview.tactic -> 'a t +(** Transform a tactic into a focussing tactic. The resulting tactic is not + focussed. *) + +val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic +(** Given a continuation producing a tactic, evaluates the focussing tactic. If + the tactic has not focussed, then the continuation is evaluated once. + Otherwise it is called in each of the currently focussed goals. *) + +(** {5 Focussing} *) + +val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t +(** Enter a goal. The resulting tactic is focussed. *) + +val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t +(** Enter a goal, without evar normalization. The resulting tactic is + focussed. *) + +val with_env : 'a t -> (Environ.env*'a) t +(** [with_env t] returns, in addition to the return type of [t], an + environment, which is the global environment if [t] does not focus on + goals, or the local goal environment if [t] focuses on goals. *) + +(** {5 Notations} *) + +val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +(** Notation for {!bind}. *) + +val (<*>) : unit t -> 'a t -> 'a t +(** Sequence. *) + +(** {5 List operations} *) + +module List : Monad.ListS with type 'a t := 'a t + +(** {5 Debug} *) + +val debug_prompt : + int -> Tacexpr.glob_tactic_expr -> (Tactic_debug.debug_info -> 'a t) -> 'a t diff --git a/tactics/g_class.ml4 b/tactics/g_class.ml4 new file mode 100644 index 00000000..a55da35e --- /dev/null +++ b/tactics/g_class.ml4 @@ -0,0 +1,84 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ progress_evars (Tacinterp.eval_tactic t) ] +END + +(** Options: depth, debug and transparency settings. *) + +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 false b) cl + +VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF +| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ + set_transparency cl true ] +END + +VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF +| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ + set_transparency cl false ] +END + +open Genarg + +let pr_debug _prc _prlc _prt b = + if b then Pp.str "debug" else Pp.mt() + +ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug +| [ "debug" ] -> [ true ] +| [ ] -> [ false ] +END + +let pr_depth _prc _prlc _prt = function + Some i -> Pp.int i + | None -> Pp.mt() + +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 CLASSIFIED AS SIDEFF + | [ "Typeclasses" "eauto" ":=" debug(d) depth(depth) ] -> [ + set_typeclasses_debug d; + set_typeclasses_depth depth + ] +END + +TACTIC EXTEND typeclasses_eauto +| [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ Proofview.V82.tactic (typeclasses_eauto l) ] +| [ "typeclasses" "eauto" ] -> [ Proofview.V82.tactic (typeclasses_eauto ~only_classes:true [Hints.typeclasses_db]) ] +END + +TACTIC EXTEND head_of_constr + [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ] +END + +TACTIC EXTEND not_evar + [ "not_evar" constr(ty) ] -> [ not_evar ty ] +END + +TACTIC EXTEND is_ground + [ "is_ground" constr(ty) ] -> [ Proofview.V82.tactic (is_ground ty) ] +END + +TACTIC EXTEND autoapply + [ "autoapply" constr(c) "using" preident(i) ] -> [ Proofview.V82.tactic (autoapply c i) ] +END diff --git a/tactics/g_eqdecide.ml4 b/tactics/g_eqdecide.ml4 new file mode 100644 index 00000000..1bd8f075 --- /dev/null +++ b/tactics/g_eqdecide.ml4 @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ decideEqualityGoal ] +END + +TACTIC EXTEND compare +| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] +END diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4 new file mode 100644 index 00000000..d60cc126 --- /dev/null +++ b/tactics/g_rewrite.ml4 @@ -0,0 +1,263 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ bl ] +END + +type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast +type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast + +let interp_strategy ist gl s = + let sigma = project gl in + sigma, strategy_of_ast s +let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s +let subst_strategy s str = str + +let pr_strategy _ _ _ (s : strategy) = Pp.str "" +let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "" +let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "" + +ARGUMENT EXTEND rewstrategy + PRINTED BY pr_strategy + + INTERPRETED BY interp_strategy + GLOBALIZED BY glob_strategy + SUBSTITUTED BY subst_strategy + + RAW_TYPED AS raw_strategy + RAW_PRINTED BY pr_raw_strategy + + GLOB_TYPED AS glob_strategy + GLOB_PRINTED BY pr_glob_strategy + + [ glob(c) ] -> [ StratConstr (c, true) ] + | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] + | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ] + | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ] + | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ] + | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ] + | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ] + | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ] + | [ "id" ] -> [ StratId ] + | [ "fail" ] -> [ StratFail ] + | [ "refl" ] -> [ StratRefl ] + | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ] + | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ] + | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ] + | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ] + | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ] + | [ "(" rewstrategy(h) ")" ] -> [ h ] + | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ] + | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] + | [ "hints" preident(h) ] -> [ StratHints (false, h) ] + | [ "terms" constr_list(h) ] -> [ StratTerms h ] + | [ "eval" red_expr(r) ] -> [ StratEval r ] + | [ "fold" constr(c) ] -> [ StratFold c ] +END + +(* By default the strategy for "rewrite_db" is top-down *) + +let db_strat db = StratUnary (Topdown, StratHints (false, db)) +let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) + +let cl_rewrite_clause_db = + if Flags.profile then + let key = Profile.declare_profile "cl_rewrite_clause_db" in + Profile.profile3 key cl_rewrite_clause_db + else cl_rewrite_clause_db + +TACTIC EXTEND rewrite_strat +| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s (Some id)) ] +| [ "rewrite_strat" rewstrategy(s) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s None) ] +| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_db db (Some id)) ] +| [ "rewrite_db" preident(db) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_db db None) ] +END + +let clsubstitute o c = + let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in + Tacticals.onAllHypsAndConcl + (fun cl -> + match cl with + | Some id when is_tac id -> tclIDTAC + | _ -> cl_rewrite_clause c o AllOccurrences cl) + +TACTIC EXTEND substitute +| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ Proofview.V82.tactic (clsubstitute o c) ] +END + + +(* Compatibility with old Setoids *) + +TACTIC EXTEND setoid_rewrite + [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] + -> [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences None) ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> + [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences (Some id))] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> + [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) None)] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> + [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> + [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))] +END + +VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] + + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) None None ] + | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + [ declare_relation a aeq n None None None ] +END + +VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF + [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + [ declare_relation a aeq n None (Some lemma2) None ] + | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF + [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation a aeq n None None (Some lemma3) ] +END + +type binders_argtype = local_binder list + +let wit_binders = + (Genarg.create_arg None "binders" : binders_argtype Genarg.uniform_genarg_type) + +let binders = Pcoq.create_generic_entry "binders" (Genarg.rawwit wit_binders) + +open Pcoq + +GEXTEND Gram + GLOBAL: binders; + binders: + [ [ b = Pcoq.Constr.binders -> b ] ]; +END + +VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None None None ] +END + +VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF + [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF + [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF + [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ] + | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ] + | [ "Add" "Morphism" constr(m) ":" ident(n) ] + (* This command may or may not open a goal *) + => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] + -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ] + | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] + -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ] + | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + "with" "signature" lconstr(s) "as" ident(n) ] + => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] + -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ] +END + +TACTIC EXTEND setoid_symmetry + [ "setoid_symmetry" ] -> [ setoid_symmetry ] + | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] +END + +TACTIC EXTEND setoid_reflexivity +[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] +END + +TACTIC EXTEND setoid_transitivity + [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] +| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] +END diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml new file mode 100644 index 00000000..d44c4ac3 --- /dev/null +++ b/tactics/geninterp.ml @@ -0,0 +1,38 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top + +module InterpObj = +struct + type ('raw, 'glb, 'top) obj = ('glb, 'top) interp_fun + let name = "interp" + let default _ = None +end + +module Interp = Register(InterpObj) + +let interp = Interp.obj +let register_interp0 = Interp.register0 + +let generic_interp ist gl v = + let unpacker wit v = + let (sigma, ans) = interp wit ist gl (glb v) in + (sigma, in_gen (topwit wit) ans) + in + unpack { unpacker; } v diff --git a/tactics/geninterp.mli b/tactics/geninterp.mli new file mode 100644 index 00000000..3c653697 --- /dev/null +++ b/tactics/geninterp.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top + +val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun + +val generic_interp : (glob_generic_argument, typed_generic_argument) interp_fun + +val register_interp0 : + ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -> unit diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml deleted file mode 100644 index 8bfebc03..00000000 --- a/tactics/hiddentac.ml +++ /dev/null @@ -1,142 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ((all_occurrences_expr,c),Names.Anonymous)) - cl) -let h_generalize_dep c = - abstract_tactic (TacGeneralizeDep c) (generalize_dep c) -let h_let_tac b na c cl eqpat = - let id = Option.default (dummy_loc,IntroAnonymous) eqpat in - let with_eq = if b then None else Some (true,id) in - abstract_tactic (TacLetTac (na,c,cl,b,eqpat)) - (letin_tac with_eq na c None cl) -let h_let_pat_tac b na c cl eqpat = - let id = Option.default (dummy_loc,IntroAnonymous) eqpat in - let with_eq = if b then None else Some (true,id) in - abstract_tactic (TacLetTac (na,snd c,cl,b,eqpat)) - (letin_pat_tac with_eq na c None cl) - -(* Derived basic tactics *) -let h_simple_induction_destruct isrec h = - abstract_tactic (TacSimpleInductionDestruct (isrec,h)) - (if isrec then (simple_induct h) else (simple_destruct h)) -let h_simple_induction = h_simple_induction_destruct true -let h_simple_destruct = h_simple_induction_destruct false - -let out_indarg = function - | ElimOnConstr (_,c) -> ElimOnConstr c - | ElimOnIdent id -> ElimOnIdent id - | ElimOnAnonHyp n -> ElimOnAnonHyp n - -let h_induction_destruct isrec ev lcl = - let lcl' = on_pi1 (List.map (fun (a,b) ->(out_indarg a,b))) lcl in - abstract_tactic (TacInductionDestruct (isrec,ev,lcl')) - (induction_destruct isrec ev lcl) -let h_new_induction ev c idl e cl = - h_induction_destruct true ev ([c,idl],e,cl) -let h_new_destruct ev c idl e cl = h_induction_destruct false ev ([c,idl],e,cl) - -let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (specialize n d) -let h_lapply c = abstract_tactic (TacLApply c) (cut_and_apply c) - -(* Context management *) -let h_clear b l = abstract_tactic (TacClear (b,l)) - ((if b then keep else clear) l) -let h_clear_body l = abstract_tactic (TacClearBody l) (clear_body l) -let h_move dep id1 id2 = - abstract_tactic (TacMove (dep,id1,id2)) (move_hyp dep id1 id2) -let h_rename l = - abstract_tactic (TacRename l) (rename_hyp l) -let h_revert l = abstract_tactic (TacRevert l) (revert l) - -(* Constructors *) -let h_left ev l = abstract_tactic (TacLeft (ev,l)) (left_with_bindings ev l) -let h_right ev l = abstract_tactic (TacRight (ev,l)) (right_with_bindings ev l) -let h_split ev l = abstract_tactic (TacSplit (ev,false,l)) (split_with_bindings ev l) -(* Moved to tacinterp because of dependencies in Tacinterp.interp -let h_any_constructor t = - abstract_tactic (TacAnyConstructor t) (any_constructor t) -*) -let h_constructor ev n l = - abstract_tactic (TacConstructor(ev,ArgArg n,l))(constructor_tac ev None n l) -let h_one_constructor n = - 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 - -(* Conversion *) -let h_reduce r cl = - abstract_tactic (TacReduce (r,cl)) (reduce r cl) -let h_change op c cl = - abstract_tactic (TacChange (op,c,cl)) (change op c cl) - -(* Equivalence relations *) -let h_reflexivity = abstract_tactic TacReflexivity intros_reflexivity -let h_symmetry c = abstract_tactic (TacSymmetry c) (intros_symmetry c) -let h_transitivity c = - abstract_tactic (TacTransitivity c) - (intros_transitivity c) - -let h_simplest_apply c = h_apply false false [dummy_loc,(c,NoBindings)] -let h_simplest_eapply c = h_apply false true [dummy_loc,(c,NoBindings)] -let h_simplest_elim c = h_elim false (c,NoBindings) None -let h_simplest_case c = h_case false (c,NoBindings) - -let h_intro_patterns l = abstract_tactic (TacIntroPattern l) (intro_patterns l) - diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli deleted file mode 100644 index ae4e1f53..00000000 --- a/tactics/hiddentac.mli +++ /dev/null @@ -1,124 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* identifier move_location -> tactic -val h_intro : identifier -> tactic -val h_intros_until : quantified_hypothesis -> tactic - -val h_assumption : tactic -val h_exact : constr -> tactic -val h_exact_no_check : constr -> tactic -val h_vm_cast_no_check : constr -> tactic - -val h_apply : advanced_flag -> evars_flag -> - constr with_bindings located list -> tactic -val h_apply_in : advanced_flag -> evars_flag -> - constr with_bindings located list -> - identifier * intro_pattern_expr located option -> tactic - -val h_elim : evars_flag -> constr with_bindings -> - constr with_bindings option -> tactic -val h_elim_type : constr -> tactic -val h_case : evars_flag -> constr with_bindings -> tactic -val h_case_type : constr -> tactic - -val h_mutual_fix : hidden_flag -> identifier -> int -> - (identifier * int * constr) list -> tactic -val h_fix : identifier option -> int -> tactic -val h_mutual_cofix : hidden_flag -> identifier -> - (identifier * constr) list -> tactic -val h_cofix : identifier option -> tactic - -val h_cut : constr -> tactic -val h_generalize : constr list -> tactic -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 -> - intro_pattern_expr located option -> tactic -val h_let_pat_tac : letin_flag -> name -> evar_map * constr -> - Tacticals.clause -> intro_pattern_expr located option -> - tactic - -(** 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 -> - (evar_map * constr with_bindings) induction_arg -> - intro_pattern_expr located option * intro_pattern_expr located option -> - constr with_bindings option -> - Tacticals.clause option -> tactic -val h_new_destruct : evars_flag -> - (evar_map * constr with_bindings) induction_arg -> - intro_pattern_expr located option * intro_pattern_expr located option -> - constr with_bindings option -> - Tacticals.clause option -> tactic -val h_induction_destruct : rec_flag -> evars_flag -> - ((evar_map * constr with_bindings) induction_arg * - (intro_pattern_expr located option * intro_pattern_expr located option)) list - * constr with_bindings option - * Tacticals.clause option -> tactic - -val h_specialize : int option -> constr with_bindings -> tactic -val h_lapply : constr -> tactic - -(** Automation tactic : see Auto *) - - -(** 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 *) -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 -val h_split : evars_flag -> constr bindings list -> tactic - -val h_one_constructor : int -> tactic -val h_simplest_left : tactic -val h_simplest_right : tactic - - -(** Conversion *) -val h_reduce : Redexpr.red_expr -> Tacticals.clause -> tactic -val h_change : - Pattern.constr_pattern option -> constr -> Tacticals.clause -> tactic - -(** Equivalence relations *) -val h_reflexivity : tactic -val h_symmetry : Tacticals.clause -> tactic -val h_transitivity : constr option -> tactic - -val h_simplest_apply : constr -> tactic -val h_simplest_eapply : constr -> tactic -val h_simplest_elim : constr -> tactic -val h_simplest_case : constr -> tactic - -val h_intro_patterns : intro_pattern_expr located list -> tactic diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index 7d12f9d0..ff2e1ff6 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,8 +1,11 @@ -Refine Extraargs +Coretactics Extratactics Eauto Class_tactics +G_class Rewrite +G_rewrite Tauto Eqdecide +G_eqdecide diff --git a/tactics/hints.ml b/tactics/hints.ml new file mode 100644 index 00000000..5621c365 --- /dev/null +++ b/tactics/hints.ml @@ -0,0 +1,1221 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* hd + | Proj (p, _) -> mkConst (Projection.constant p) + | _ -> raise Bound + +let head_constr c = + try head_constr_bound c with Bound -> error "Bound head variable." + +let decompose_app_bound t = + let t = strip_outer_cast t in + let _,ccl = decompose_prod_assum t in + let hd,args = decompose_app_vect ccl in + match kind_of_term hd with + | Const (c,u) -> ConstRef c, args + | Ind (i,u) -> IndRef i, args + | Construct (c,u) -> ConstructRef c, args + | Var id -> VarRef id, args + | Proj (p, c) -> ConstRef (Projection.constant p), Array.cons c args + | _ -> raise Bound + +(************************************************************************) +(* The Type of Constructions Autotactic Hints *) +(************************************************************************) + +type 'a auto_tactic = + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) + | Unfold_nth of evaluable_global_reference (* Hint Unfold *) + | Extern of glob_tactic_expr (* Hint Extern *) + +type hints_path_atom = + | PathHints of global_reference list + | PathAny + +type hints_path = + | PathAtom of hints_path_atom + | PathStar of hints_path + | PathSeq of hints_path * hints_path + | PathOr of hints_path * hints_path + | PathEmpty + | PathEpsilon + +type hint_term = + | IsGlobRef of global_reference + | IsConstr of constr * Univ.universe_context_set + +type 'a gen_auto_tactic = { + pri : int; (* A number lower is higher priority *) + poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) + pat : constr_pattern option; (* A pattern for the concl of the Goal *) + name : hints_path_atom; (* A potential name to refer to the hint *) + code : 'a auto_tactic (* the tactic to apply when the concl matches pat *) +} + +type pri_auto_tactic = (constr * clausenv) gen_auto_tactic + +type hint_entry = global_reference option * + (constr * types * Univ.universe_context_set) gen_auto_tactic + +let eq_hints_path_atom p1 p2 = match p1, p2 with +| PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2 +| PathAny, PathAny -> true +| (PathHints _ | PathAny), _ -> false + +let eq_auto_tactic t1 t2 = match t1, t2 with +| Res_pf (c1, _), Res_pf (c2, _) -> Constr.equal c1 c2 +| ERes_pf (c1, _), ERes_pf (c2, _) -> Constr.equal c1 c2 +| Give_exact (c1, _), Give_exact (c2, _) -> Constr.equal c1 c2 +| Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> Constr.equal c1 c2 +| Unfold_nth gr1, Unfold_nth gr2 -> eq_egr gr1 gr2 +| Extern tac1, Extern tac2 -> tac1 == tac2 (** May cause redundancy in addkv *) +| (Res_pf _ | ERes_pf _ | Give_exact _ | Res_pf_THEN_trivial_fail _ + | Unfold_nth _ | Extern _), _ -> false + +let eq_gen_auto_tactic t1 t2 = + Int.equal t1.pri t2.pri && + Option.equal constr_pattern_eq t1.pat t2.pat && + eq_hints_path_atom t1.name t2.name && + eq_auto_tactic t1.code t2.code + +let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) = + let d = pri1 - pri2 in + if Int.equal d 0 then id2 - id1 + else d + +let pri_order t1 t2 = pri_order_int t1 t2 <= 0 + +(* Nov 98 -- Papageno *) +(* Les Hints sont ré-organisés en plusieurs databases. + + La table impérative "searchtable", de type "hint_db_table", + associe une database (hint_db) à chaque nom. + + Une hint_db est une table d'association fonctionelle constr -> search_entry + 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 ont un pattern + - un discrimination net borné (Btermdn.t) constitué de tous les + patterns de la seconde liste de tactiques *) + +type stored_data = int * pri_auto_tactic + (* First component is the index of insertion in the table, to keep most recent first semantics. *) + +module Bounded_net = Btermdn.Make(struct + type t = stored_data + let compare = pri_order_int + end) + +type search_entry = stored_data list * stored_data list * Bounded_net.t * bool array list + + +let empty_se = ([],[],Bounded_net.create (),[]) + +let eq_pri_auto_tactic (_, x) (_, y) = + if Int.equal x.pri y.pri && Option.equal constr_pattern_eq x.pat y.pat then + match x.code,y.code with + | Res_pf (cstr,_),Res_pf (cstr1,_) -> + Term.eq_constr cstr cstr1 + | ERes_pf (cstr,_),ERes_pf (cstr1,_) -> + Term.eq_constr cstr cstr1 + | Give_exact (cstr,_),Give_exact (cstr1,_) -> + Term.eq_constr cstr cstr1 + | Res_pf_THEN_trivial_fail (cstr,_) + ,Res_pf_THEN_trivial_fail (cstr1,_) -> + Term.eq_constr cstr cstr1 + | _,_ -> false + else + false + +let add_tac pat t st (l,l',dn,m) = + match pat with + | None -> + if not (List.exists (eq_pri_auto_tactic t) l) then (List.insert pri_order t l, l', dn, m) + else (l, l', dn, m) + | Some pat -> + if not (List.exists (eq_pri_auto_tactic t) l') + then (l, List.insert pri_order t l', Bounded_net.add st dn (pat,t), m) else (l, l', dn, m) + +let rebuild_dn st ((l,l',dn,m) : search_entry) = + let dn' = + List.fold_left + (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t))) + (Bounded_net.create ()) l' + in + (l, l', dn', m) + +let lookup_tacs concl st (l,l',dn) = + let l' = Bounded_net.lookup st dn concl in + let sl' = List.stable_sort pri_order_int l' in + List.merge pri_order_int l sl' + +module Constr_map = Map.Make(RefOrdered) + +let is_transparent_gr (ids, csts) = function + | VarRef id -> Id.Pred.mem id ids + | ConstRef cst -> Cpred.mem cst csts + | IndRef _ | ConstructRef _ -> false + +let strip_params env c = + match kind_of_term c with + | App (f, args) -> + (match kind_of_term f with + | Const (p,_) -> + let cb = lookup_constant p env in + (match cb.Declarations.const_proj with + | Some pb -> + let n = pb.Declarations.proj_npars in + if Array.length args > n then + mkApp (mkProj (Projection.make p false, args.(n)), + Array.sub args (n+1) (Array.length args - (n + 1))) + else c + | None -> c) + | _ -> c) + | _ -> c + +let instantiate_hint p = + let mk_clenv c cty ctx = + let env = Global.env () in + let sigma = Evd.merge_context_set univ_flexible (Evd.from_env env) ctx in + let cl = mk_clenv_from_env (Global.env()) sigma None (c,cty) in + {cl with templval = + { cl.templval with rebus = strip_params env cl.templval.rebus }; + env = empty_env} + in + let code = match p.code with + | Res_pf (c, cty, ctx) -> Res_pf (c, mk_clenv c cty ctx) + | ERes_pf (c, cty, ctx) -> ERes_pf (c, mk_clenv c cty ctx) + | Res_pf_THEN_trivial_fail (c, cty, ctx) -> + Res_pf_THEN_trivial_fail (c, mk_clenv c cty ctx) + | Give_exact (c, cty, ctx) -> Give_exact (c, mk_clenv c cty ctx) + | Unfold_nth e -> Unfold_nth e + | Extern t -> Extern t + in { pri = p.pri; poly = p.poly; name = p.name; pat = p.pat; code = code } + +let hints_path_atom_eq h1 h2 = match h1, h2 with +| PathHints l1, PathHints l2 -> List.equal eq_gr l1 l2 +| PathAny, PathAny -> true +| _ -> false + +let rec hints_path_eq h1 h2 = match h1, h2 with +| PathAtom h1, PathAtom h2 -> hints_path_atom_eq h1 h2 +| PathStar h1, PathStar h2 -> hints_path_eq h1 h2 +| PathSeq (l1, r1), PathSeq (l2, r2) -> + hints_path_eq l1 l2 && hints_path_eq r1 r2 +| PathOr (l1, r1), PathOr (l2, r2) -> + hints_path_eq l1 l2 && hints_path_eq r1 r2 +| PathEmpty, PathEmpty -> true +| PathEpsilon, PathEpsilon -> true +| _ -> false + +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 hints_path_atom_eq 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 eq_gr 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 hints_path_eq p p' && hints_path_eq q q' then h + else normalize_path (PathOr (p', q')) + | PathSeq (p, q) -> + let p', q' = normalize_path p, normalize_path q in + if hints_path_eq p p' && hints_path_eq 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) -> pr_sequence 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 subst_path_atom subst p = + match p with + | PathAny -> p + | PathHints grs -> + let gr' gr = fst (subst_global subst gr) in + let grs' = List.smartmap gr' grs in + if grs' == grs then p else PathHints grs' + +let rec subst_hints_path subst hp = + match hp with + | PathAtom p -> + let p' = subst_path_atom subst p in + if p' == p then hp else PathAtom p' + | 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 : Id.Set.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 + or with no associated pattern. *) + 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 = (Id.Set.empty, Cset.empty); + hintdb_max_id = 0; + use_dn = use_dn; + hintdb_map = Constr_map.empty; + hintdb_nopat = [] } + + let find key db = + try Constr_map.find key db.hintdb_map + with Not_found -> empty_se + + let realize_tac (id,tac) = tac + + let matches_mode args mode = + Array.length args == Array.length mode && + Array.for_all2 (fun arg m -> not (m && occur_existential arg)) args mode + + let matches_modes args modes = + if List.is_empty modes then true + else List.exists (matches_mode args) modes + + let map_none db = + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) []) + + let map_all k db = + let (l,l',_,_) = find k db in + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l') + + (** Precondition: concl has no existentials *) + let map_auto (k,args) concl db = + let (l,l',dn,m) = find k db in + let st = if db.use_dn then (Some db.hintdb_state) else None in + let l' = lookup_tacs concl st (l,l',dn) in + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l') + + let map_existential (k,args) concl db = + let (l,l',_,m) = find k db in + if matches_modes args m then + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l') + else List.map realize_tac (List.map snd db.hintdb_nopat) + + (* [c] contains an existential *) + let map_eauto (k,args) concl db = + let (l,l',dn,m) = find k db in + if matches_modes args m then + let st = if db.use_dn then Some db.hintdb_state else None in + let l' = lookup_tacs concl st (l,l',dn) in + List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l') + else List.map realize_tac (List.map snd db.hintdb_nopat) + + let is_exact = function + | Give_exact _ -> true + | _ -> false + + 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 && + 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 -> + (** ppedrot: this equality here is dubious. Maybe we can remove it? *) + let is_present (_, (_, v')) = eq_gen_auto_tactic v v' in + if not (List.exists is_present db.hintdb_nopat) then + (** FIXME *) + { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } + else db + | Some gr -> + let oval = find gr db in + { 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,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat + + let add_one (k, v) db = + let v = instantiate_hint v in + let st',db,rebuild = + match v.code with + | Unfold_nth egr -> + let addunf (ids,csts) (ids',csts') = + match egr with + | EvalVarRef id -> (Id.Pred.add id ids, csts), (Id.Set.add id ids', csts') + | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts') + in + let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in + state, { db with hintdb_unfolds = unfs }, true + | _ -> db.hintdb_state, db, false + in + let db = if db.use_dn && rebuild then rebuild_db st' db else db + in addkv k (next_hint_id db) v db + + let add_list l db = List.fold_left (fun db k -> add_one k db) db l + + let remove_sdl p sdl = List.smartfilter p sdl + let remove_he st p (sl1, sl2, dn, m 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, m) + + let remove_list grs db = + let filter (_, h) = + match h.name with PathHints [gr] -> not (List.mem_f eq_gr 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 (fun x -> realize_tac (snd x)) db.hintdb_nopat); + Constr_map.iter (fun k (l,l',_,m) -> f (Some k) m (List.map realize_tac (l@l'))) db.hintdb_map + + let fold f db accu = + let accu = f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in + Constr_map.fold (fun k (l,l',_,m) -> f (Some k) m (List.map snd (l@l'))) db.hintdb_map accu + + let transparent_state db = db.hintdb_state + + let set_transparent_state db st = + 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 add_mode gr m db = + let (l,l',dn,ms) = find gr db in + { db with hintdb_map = Constr_map.add gr (l,l',dn,m :: ms) db.hintdb_map } + + let cut db = db.hintdb_cut + + let unfolds db = db.hintdb_unfolds + + let use_dn db = db.use_dn + +end + +module Hintdbmap = String.Map + +type hint_db = Hint_db.t + +type hint_db_table = hint_db Hintdbmap.t ref + +type hint_db_name = string + +(** Initially created hint databases, for typeclasses and rewrite *) + +let typeclasses_db = "typeclass_instances" +let rewrite_db = "rewrite" + +let auto_init_db = + Hintdbmap.add typeclasses_db (Hint_db.empty full_transparent_state true) + (Hintdbmap.add rewrite_db (Hint_db.empty cst_full_transparent_state true) + Hintdbmap.empty) + +let searchtable : hint_db_table = ref auto_init_db + +let searchtable_map name = + Hintdbmap.find name !searchtable +let searchtable_add (name,db) = + searchtable := Hintdbmap.add name db !searchtable +let current_db_names () = Hintdbmap.domain !searchtable +let current_db () = Hintdbmap.bindings !searchtable + +let current_pure_db () = + List.map snd (Hintdbmap.bindings (Hintdbmap.remove "v62" !searchtable)) + +let error_no_such_hint_database x = + error ("No such Hint database: "^x^".") + +(**************************************************************************) +(* Definition of the summary *) +(**************************************************************************) + +let hints_init : (unit -> unit) ref = ref (fun () -> ()) +let add_hints_init f = + let init = !hints_init in + hints_init := (fun () -> init (); f ()) + +let init () = searchtable := auto_init_db; !hints_init () +let freeze _ = !searchtable +let unfreeze fs = searchtable := fs + +let _ = Summary.declare_summary "search" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } + +(**************************************************************************) +(* Auxiliary functions to prepare AUTOHINT objects *) +(**************************************************************************) + +let rec nb_hyp c = match kind_of_term c with + | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2 + | _ -> 0 + +(* adding and removing tactics in the search table *) + +let try_head_pattern c = + try head_pattern_bound c + with BoundPattern -> error "Bound head variable." + +let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = + let cty = strip_outer_cast cty in + match kind_of_term cty with + | Prod _ -> failwith "make_exact_entry" + | _ -> + let pat = snd (Patternops.pattern_of_constr env sigma cty) in + let hd = + try head_pattern_bound pat + with BoundPattern -> failwith "make_exact_entry" + in + (Some hd, + { pri = (match pri with None -> 0 | Some p -> p); + poly = poly; + pat = Some pat; + name = name; + code = Give_exact (c, cty, ctx) }) + +let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = + let cty = if hnf then hnf_constr env sigma cty else cty in + match kind_of_term cty with + | Prod _ -> + let sigma' = Evd.merge_context_set univ_flexible sigma ctx in + let ce = mk_clenv_from_env env sigma' None (c,cty) in + let c' = clenv_type (* ~reduce:false *) ce in + let pat = snd (Patternops.pattern_of_constr env ce.evd c') in + let hd = + try head_pattern_bound pat + with BoundPattern -> failwith "make_apply_entry" in + let nmiss = List.length (clenv_missing ce) in + if Int.equal nmiss 0 then + (Some hd, + { pri = (match pri with None -> nb_hyp cty | Some p -> p); + poly = poly; + pat = Some pat; + name = name; + code = Res_pf(c,cty,ctx) }) + else begin + if not eapply then failwith "make_apply_entry"; + if verbose then + msg_warning (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); + poly = poly; + pat = Some pat; + name = name; + code = ERes_pf(c,cty,ctx) }) + end + | _ -> failwith "make_apply_entry" + +(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose + c is a constr + cty is the type of constr *) + +let fresh_global_or_constr env sigma poly cr = + match cr with + | IsGlobRef gr -> Universes.fresh_global_instance env gr + | IsConstr (c, ctx) -> (c, ctx) + +let make_resolves env sigma flags pri poly ?name cr = + let c, ctx = fresh_global_or_constr env sigma poly cr in + let cty = Retyping.get_type_of env sigma c in + let try_apply f = + try Some (f (c, cty, ctx)) with Failure _ -> None in + let ents = List.map_filter try_apply + [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name] + in + if List.is_empty ents then + errorlabstrm "Hint" + (pr_lconstr c ++ spc() ++ + (if pi1 flags then str"cannot be used as a hint." + else str "can be used as a hint only for eauto.")); + ents + +(* 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 false + ~name:(PathHints [VarRef hname]) + (mkVar hname, htyp, Univ.ContextSet.empty)] + with + | Failure _ -> [] + | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") + +(* REM : in most cases hintname = id *) +let make_unfold eref = + let g = global_of_evaluable_reference eref in + (Some g, + { pri = 4; + poly = false; + pat = None; + name = PathHints [g]; + code = Unfold_nth eref }) + +let make_extern pri pat tacast = + let hdconstr = Option.map try_head_pattern pat in + (hdconstr, + { pri = pri; + poly = false; + pat = pat; + name = PathAny; + code = Extern tacast }) + +let make_mode ref m = + let ty = Global.type_of_global_unsafe ref in + let ctx, t = decompose_prod ty in + let n = List.length ctx in + let m' = Array.of_list m in + if not (n == Array.length m') then + errorlabstrm "Hint" + (pr_global ref ++ str" has " ++ int n ++ + str" arguments while the mode declares " ++ int (Array.length m')) + else m' + +let make_trivial env sigma poly ?(name=PathAny) r = + let c,ctx = fresh_global_or_constr env sigma poly r in + let sigma = Evd.merge_context_set univ_flexible sigma ctx in + let t = hnf_constr env sigma (type_of env sigma c) in + let hd = head_of_constr_reference (head_constr t) in + let ce = mk_clenv_from_env env sigma None (c,t) in + (Some hd, { pri=1; + poly = poly; + pat = Some (snd (Patternops.pattern_of_constr env ce.evd (clenv_type ce))); + name = name; + code=Res_pf_THEN_trivial_fail(c,t,ctx) }) + + + +(**************************************************************************) +(* declaration of the AUTOHINT library object *) +(**************************************************************************) + +(* If the database does not exist, it is created *) +(* TODO: should a warning be printed in this case ?? *) + +let get_db dbname = + try searchtable_map dbname + with Not_found -> Hint_db.empty empty_transparent_state false + +let add_hint dbname hintlist = + let db = get_db dbname in + let db' = Hint_db.add_list hintlist db in + searchtable_add (dbname,db') + +let add_transparency dbname grs b = + let db = get_db dbname in + let st = Hint_db.transparent_state db in + let st' = + List.fold_left (fun (ids, csts) gr -> + match gr with + | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts) + | EvalVarRef v -> (if b then Id.Pred.add else Id.Pred.remove) v ids, csts) + st grs + in searchtable_add (dbname, Hint_db.set_transparent_state db st') + +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 + | AddMode of global_reference * bool array + +let add_cut dbname path = + let db = get_db dbname in + let db' = Hint_db.add_cut path db in + searchtable_add (dbname, db') + +let add_mode dbname l m = + let db = get_db dbname in + let db' = Hint_db.add_mode l m 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 + | AddHints hints -> add_hint name hints + | RemoveHints grs -> remove_hint name grs + | AddCut path -> add_cut name path + | AddMode (l, m) -> add_mode name l m + +let subst_autohint (subst,(local,name,hintlist as obj)) = + let subst_key gr = + let (lab'', elab') = subst_global subst gr in + let gr' = + (try head_of_constr_reference (head_constr_bound elab') + with Bound -> lab'') + in if gr' == gr then gr else gr' + in + let subst_hint (k,data as hint) = + let k' = Option.smartmap subst_key k in + let pat' = Option.smartmap (subst_pattern subst) data.pat in + let code' = match data.code with + | Res_pf (c,t,ctx) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t'==t then data.code else Res_pf (c', t',ctx) + | ERes_pf (c,t,ctx) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t'==t then data.code else ERes_pf (c',t',ctx) + | Give_exact (c,t,ctx) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t'== t then data.code else Give_exact (c',t',ctx) + | Res_pf_THEN_trivial_fail (c,t,ctx) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t',ctx) + | Unfold_nth ref -> + let ref' = subst_evaluable_reference subst ref in + if ref==ref' then data.code else Unfold_nth ref' + | Extern tac -> + let tac' = Tacsubst.subst_tactic subst tac in + if tac==tac' then data.code else Extern tac' + in + let name' = subst_path_atom subst data.name in + let data' = + if data.pat==pat' && data.name == name' && data.code==code' then data + else { data with pat = pat'; name = name'; 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)) + | AddHints hintlist -> + let hintlist' = List.smartmap subst_hint hintlist in + if hintlist' == hintlist then obj else + (local,name,AddHints hintlist') + | RemoveHints grs -> + let grs' = List.smartmap (subst_global_reference subst) 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') + | AddMode (l,m) -> + let l' = subst_global_reference subst l in + (local, name, AddMode (l', m)) + +let classify_autohint ((local,name,hintlist) as obj) = + match hintlist with + | AddHints [] -> Dispose + | _ -> if local then Dispose else Substitute obj + +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; } + +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 List.is_empty dbnames then ["core"] else dbnames in + List.iter + (fun dbname -> + Lib.add_anonymous_leaf (inAutoHint(local, dbname, RemoveHints grs))) + dbnames + +(**************************************************************************) +(* The "Hint" vernacular command *) +(**************************************************************************) +let add_resolves env sigma clist local dbnames = + List.iter + (fun dbname -> + Lib.add_anonymous_leaf + (inAutoHint + (local,dbname, AddHints + (List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> + make_resolves env sigma (true,hnf,Flags.is_verbose()) + pri poly ~name:path gr) clist))))) + dbnames + +let add_unfolds l local dbnames = + List.iter + (fun dbname -> Lib.add_anonymous_leaf + (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_mode l m local dbnames = + List.iter + (fun dbname -> Lib.add_anonymous_leaf + (let m' = make_mode l m in + (inAutoHint (local,dbname, AddMode (l,m'))))) + dbnames + +let add_transparency l b local dbnames = + List.iter + (fun dbname -> Lib.add_anonymous_leaf + (inAutoHint (local,dbname, AddTransparency (l, b)))) + dbnames + +let add_extern pri pat tacast local dbname = + let pat = match pat with + | None -> None + | Some (_, pat) -> Some pat + in + let hint = local, dbname, AddHints [make_extern pri pat tacast] in + Lib.add_anonymous_leaf (inAutoHint hint) + +let add_externs pri pat tacast local dbnames = + List.iter (add_extern pri pat tacast local) dbnames + +let add_trivials env sigma l local dbnames = + List.iter + (fun dbname -> + Lib.add_anonymous_leaf ( + inAutoHint(local,dbname, + AddHints (List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l)))) + dbnames + +let (forward_intern_tac, extern_intern_tac) = Hook.make () + +type hnf = bool + +type hints_entry = + | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * hint_term) list + | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list + | HintsCutEntry of hints_path + | HintsUnfoldEntry of evaluable_global_reference list + | HintsTransparencyEntry of evaluable_global_reference list * bool + | HintsModeEntry of global_reference * bool list + | HintsExternEntry of + int * (patvar list * constr_pattern) option * glob_tactic_expr + +let default_prepare_hint_ident = Id.of_string "H" + +exception Found of constr * types + +let prepare_hint check env init (sigma,c) = + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + (* We re-abstract over uninstantiated evars. + It is actually a bit stupid to generalize over evars since the first + 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 not (Int.Set.is_empty (free_rels t)) 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 default_prepare_hint_ident (fun id -> Id.Set.mem id !vars) in + vars := Id.Set.add id !vars; + subst := (evar,mkVar id)::!subst; + mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in + let c' = iter c in + if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c'; + let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in + IsConstr (c', diff) + +let interp_hints poly = + fun h -> + let f c = + let evd,c = Constrintern.interp_open_constr (Global.env()) Evd.empty c in + prepare_hint true (Global.env()) Evd.empty (evd,c) in + let fref r = + let gr = global_with_alias r in + Dumpglob.add_glob (loc_of_reference r) gr; + gr in + let fr r = + evaluable_of_global_reference (Global.env()) (fref r) + in + let fi c = + match c with + | HintsReference c -> + let gr = global_with_alias c in + (PathHints [gr], poly, IsGlobRef gr) + | HintsConstr c -> (PathAny, poly, f c) + in + let fres (pri, b, r) = + let path, poly, gr = fi r in + (pri, poly, b, path, gr) + in + let fp = Constrintern.intern_constr_pattern (Global.env()) in + match h with + | 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) + | HintsMode (r, l) -> HintsModeEntry (fref r, l) + | HintsConstructors lqid -> + let constr_hints_of_ind qid = + let ind = global_inductive_with_alias qid in + let mib,_ = Global.lookup_inductive ind in + Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind"; + List.init (nconstructors ind) + (fun i -> let c = (ind,i+1) in + let gr = ConstructRef c in + None, mib.Declarations.mind_polymorphic, true, + PathHints [gr], IsGlobRef gr) + in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) + | HintsExtern (pri, patcom, tacexp) -> + let pat = Option.map fp patcom in + let l = match pat with None -> [] | Some (l, _) -> l in + let tacexp = Hook.get forward_intern_tac l tacexp in + HintsExternEntry (pri, pat, tacexp) + +let add_hints local dbnames0 h = + if String.List.mem "nocore" dbnames0 then + error "The hint database \"nocore\" is meant to stay empty."; + let dbnames = if List.is_empty 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 + | HintsModeEntry (l,m) -> add_mode l m local dbnames + | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames + | HintsTransparencyEntry (lhints, b) -> + add_transparency lhints b local dbnames + | HintsExternEntry (pri, pat, tacexp) -> + add_externs pri pat tacexp local dbnames + +let expand_constructor_hints env sigma lems = + List.map_append (fun (evd,lem) -> + match kind_of_term lem with + | Ind (ind,u) -> + List.init (nconstructors ind) + (fun i -> IsConstr (mkConstructU ((ind,i+1),u), + Univ.ContextSet.empty)) + | _ -> + [prepare_hint false env sigma (evd,lem)]) lems + +(* builds a hint database from a constr signature *) +(* typically used with (lid, ltyp) = pf_hyps_types *) + +let add_hint_lemmas env sigma eapply lems hint_db = + let lems = expand_constructor_hints env sigma lems in + let hintlist' = + List.map_append (make_resolves env sigma (eapply,true,false) None true) lems in + Hint_db.add_list hintlist' hint_db + +let make_local_hint_db env sigma ts eapply lems = + let sign = Environ.named_context env in + let ts = match ts with + | None -> Hint_db.transparent_state (searchtable_map "core") + | Some ts -> ts + in + let hintlist = List.map_append (make_resolve_hyp env sigma) sign in + add_hint_lemmas env sigma eapply lems + (Hint_db.add_list hintlist (Hint_db.empty ts false)) + +let make_local_hint_db = + if Flags.profile then + let key = Profile.declare_profile "make_local_hint_db" in + Profile.profile4 key make_local_hint_db + else make_local_hint_db + +let make_local_hint_db env sigma ?ts eapply lems = + make_local_hint_db env sigma ts eapply lems + +let make_db_list dbnames = + let use_core = not (List.mem "nocore" dbnames) in + let dbnames = List.remove String.equal "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 + +(**************************************************************************) +(* Functions for printing the hints *) +(**************************************************************************) + +let pr_autotactic = + function + | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c) + | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c) + | Give_exact (c,clenv) -> (str"exact " ++ pr_constr c) + | Res_pf_THEN_trivial_fail (c,clenv) -> + (str"apply " ++ pr_constr c ++ str" ; trivial") + | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) + | Extern tac -> + let env = + try + let (_, env) = Pfedit.get_current_goal_context () in + env + with e when Errors.noncritical e -> Global.env () + in + (str "(*external*) " ++ Pptactic.pr_glob_tactic env tac) + +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 ()) + +let pr_hints_db (name,db,hintlist) = + (str "In the database " ++ str name ++ str ":" ++ + if List.is_empty hintlist then (str " nothing" ++ fnl ()) + else (fnl () ++ pr_hint_list hintlist)) + +(* Print all hints associated to head c in any database *) +let pr_hint_list_for_head c = + let dbs = current_db () in + let validate (name, db) = + let hints = List.map (fun v -> 0, v) (Hint_db.map_all c db) in + (name, db, hints) + in + let valid_dbs = List.map validate dbs in + if List.is_empty valid_dbs then + (str "No hint declared for :" ++ pr_global c) + else + hov 0 + (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ + hov 0 (prlist pr_hints_db valid_dbs)) + +let pr_hint_ref ref = pr_hint_list_for_head ref + +(* Print all hints associated to head id in any database *) + +let pr_hint_term cl = + try + let dbs = current_db () in + let valid_dbs = + let fn = try + let hdc = decompose_app_bound cl in + if occur_existential cl then + Hint_db.map_existential hdc cl + else Hint_db.map_auto hdc cl + with Bound -> Hint_db.map_none + in + let fn db = List.map (fun x -> 0, x) (fn db) in + List.map (fun (name, db) -> (name, db, fn db)) dbs + in + if List.is_empty valid_dbs then + (str "No hint applicable for current goal") + else + (str "Applicable Hints :" ++ fnl () ++ + hov 0 (prlist pr_hints_db valid_dbs)) + with Match_failure _ | Failure _ -> + (str "No hint applicable for current goal") + +(* print all hints that apply to the concl of the current goal *) +let pr_applicable_hint () = + let pts = get_pftreestate () in + let glss = Proof.V82.subgoals pts in + match glss.Evd.it with + | [] -> Errors.error "No focused goal." + | g::_ -> + pr_hint_term (Goal.V82.concl glss.Evd.sigma g) + +(* displays the whole hint database db *) +let pr_hint_db db = + let pr_mode = prvect_with_sep spc (fun x -> if x then str"+" else str"-") in + let pr_modes l = + if List.is_empty l then mt () + else str" (modes " ++ prlist_with_sep pr_comma pr_mode l ++ str")" + in + let content = + let fold head modes hintlist accu = + let goal_descr = match head with + | None -> str "For any goal" + | Some head -> str "For " ++ pr_global head ++ pr_modes modes + in + let hints = pr_hint_list (List.map (fun x -> (0, x)) hintlist) in + let hint_descr = hov 0 (goal_descr ++ str " -> " ++ hints) in + accu ++ hint_descr + in + Hint_db.fold fold db (mt ()) + in + let (ids, csts) = Hint_db.transparent_state db in + hov 0 + ((if Hint_db.use_dn db then str"Discriminated database" + else str"Non-discriminated database")) ++ fnl () ++ + hov 2 (str"Unfoldable variable definitions: " ++ pr_idpred ids) ++ fnl () ++ + hov 2 (str"Unfoldable constant definitions: " ++ pr_cpred csts) ++ fnl () ++ + hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)) ++ fnl () ++ + content + +let pr_hint_db_by_name dbname = + try + let db = searchtable_map dbname in pr_hint_db db + with Not_found -> + error_no_such_hint_database dbname + +(* displays all the hints of all databases *) +let pr_searchtable () = + let fold name db accu = + accu ++ str "In the database " ++ str name ++ str ":" ++ fnl () ++ + pr_hint_db db ++ fnl () + in + Hintdbmap.fold fold !searchtable (mt ()) + diff --git a/tactics/hints.mli b/tactics/hints.mli new file mode 100644 index 00000000..45cf562c --- /dev/null +++ b/tactics/hints.mli @@ -0,0 +1,227 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* global_reference * constr array + +(** Pre-created hint databases *) + +type 'a auto_tactic = + | Res_pf of 'a (* Hint Apply *) + | ERes_pf of 'a (* Hint EApply *) + | Give_exact of 'a + | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) + | Unfold_nth of evaluable_global_reference (* Hint Unfold *) + | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) + +type hints_path_atom = + | PathHints of global_reference list + | PathAny + +type 'a gen_auto_tactic = { + pri : int; (** A number between 0 and 4, 4 = lower priority *) + poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) + pat : constr_pattern option; (** A pattern for the concl of the Goal *) + name : hints_path_atom; (** A potential name to refer to the hint *) + code : 'a auto_tactic; (** the tactic to apply when the concl matches pat *) +} + +type pri_auto_tactic = (constr * clausenv) gen_auto_tactic + +type search_entry + +(** The head may not be bound. *) + +type hint_entry = global_reference option * + (constr * types * Univ.universe_context_set) gen_auto_tactic + +type hints_path = + | PathAtom of hints_path_atom + | PathStar of hints_path + | PathSeq of hints_path * hints_path + | PathOr of hints_path * hints_path + | PathEmpty + | PathEpsilon + +val normalize_path : hints_path -> 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 + type t + val empty : transparent_state -> bool -> t + val find : global_reference -> t -> search_entry + val map_none : t -> pri_auto_tactic list + + (** All hints associated to the reference *) + val map_all : global_reference -> t -> pri_auto_tactic list + + (** All hints associated to the reference, respecting modes if evars appear in the + arguments, _not_ using the discrimination net. *) + val map_existential : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list + + (** All hints associated to the reference, respecting modes if evars appear in the + arguments and using the discrimination net. *) + val map_eauto : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list + + (** All hints associated to the reference, respecting modes if evars appear in the + arguments. *) + val map_auto : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list + + val add_one : hint_entry -> t -> t + val add_list : (hint_entry) list -> t -> t + val remove_one : global_reference -> t -> t + val remove_list : global_reference list -> t -> t + val iter : (global_reference option -> bool array list -> 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 -> Id.Set.t * Cset.t + end + +type hint_db_name = string + +type hint_db = Hint_db.t + +type hnf = bool + +type hint_term = + | IsGlobRef of global_reference + | IsConstr of constr * Univ.universe_context_set + +type hints_entry = + | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * + hint_term) list + | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list + | HintsCutEntry of hints_path + | HintsUnfoldEntry of evaluable_global_reference list + | HintsTransparencyEntry of evaluable_global_reference list * bool + | HintsModeEntry of global_reference * bool list + | HintsExternEntry of + int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr + +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]. + [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 -> String.Set.t + +val current_pure_db : unit -> hint_db list + +val interp_hints : polymorphic -> hints_expr -> hints_entry + +val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit + +val prepare_hint : bool (* Check no remaining evars *) -> env -> evar_map -> + open_constr -> hint_term + +(** [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 : env -> evar_map -> int option -> polymorphic -> ?name:hints_path_atom -> + (constr * types * Univ.universe_context_set) -> hint_entry + +(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)]. + [eapply] is true if this hint will be used only with EApply; + [hnf] should be true if we should expand the head of cty before searching for + products; + [c] is the term given as an exact proof to solve the goal; + [cty] is the type of [c]. *) + +val make_apply_entry : + env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + (constr * types * Univ.universe_context_set) -> hint_entry + +(** A constr which is Hint'ed will be: + - (1) used as an Exact, if it does not start with a product + - (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 -> polymorphic -> ?name:hints_path_atom -> + hint_term -> hint_entry list + +(** [make_resolve_hyp hname htyp]. + used to add an hypothesis to the local hint database; + Never raises a user exception; + If the hyp cannot be used as a Hint, the empty list is returned. *) + +val make_resolve_hyp : + env -> evar_map -> named_declaration -> hint_entry list + +(** [make_extern pri pattern tactic_expr] *) + +val make_extern : + int -> constr_pattern option -> Tacexpr.glob_tactic_expr + -> hint_entry + +val extern_intern_tac : + (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) Hook.t + +(** 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 : env -> evar_map -> ?ts:transparent_state -> bool -> open_constr list -> hint_db + +val make_db_list : hint_db_name list -> hint_db list + +(** Initially created hint databases, for typeclasses and rewrite *) + +val typeclasses_db : hint_db_name +val rewrite_db : hint_db_name + +(** Printing hints *) + +val pr_searchtable : unit -> std_ppcmds +val pr_applicable_hint : unit -> std_ppcmds +val pr_hint_ref : global_reference -> std_ppcmds +val pr_hint_db_by_name : hint_db_name -> std_ppcmds +val pr_hint_db : Hint_db.t -> std_ppcmds +val pr_autotactic : (constr * 'a) auto_tactic -> Pp.std_ppcmds + +(** Hook for changing the initialization of auto *) + +val add_hints_init : (unit -> unit) -> unit + diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index f8c1db27..4b94f420 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -1,29 +1,24 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let (hdapp,args) = decompose_app t in (match kind_of_term hdapp with - | Ind ind -> - if not (Global.lookup_mind (fst ind)).mind_finite then + | Ind (ind,u) -> + if (Global.lookup_mind (fst ind)).mind_finite == Decl_kinds.CoFinite then Some (hdapp,args) else None @@ -83,55 +78,67 @@ let has_nodep_prod = has_nodep_prod_after 0 (* style: None = record; Some false = conjunction; Some true = strict conj *) -let match_with_one_constructor style allow_rec t = +let is_strict_conjunction = function +| Some true -> true +| _ -> false + +let is_lax_conjunction = function +| Some false -> true +| _ -> false + +let match_with_one_constructor style onlybinary allow_rec t = let (hdapp,args) = decompose_app t in - match kind_of_term hdapp with + let res = match kind_of_term hdapp with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in - if (Array.length mip.mind_consnames = 1) - && (allow_rec or not (mis_is_recursive (ind,mib,mip))) - && (mip.mind_nrealargs = 0) + let (mib,mip) = Global.lookup_inductive (fst ind) in + if Int.equal (Array.length mip.mind_consnames) 1 + && (allow_rec || not (mis_is_recursive (fst ind,mib,mip))) + && (Int.equal mip.mind_nrealargs 0) then - if style = Some true (* strict conjunction *) then + if is_strict_conjunction style (* strict conjunction *) then let ctx = (prod_assum (snd (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in if List.for_all - (fun (_,b,c) -> b=None && isRel c && destRel c = mib.mind_nparams) ctx + (fun (_,b,c) -> Option.is_empty b && isRel c && Int.equal (destRel c) mib.mind_nparams) ctx then Some (hdapp,args) else None else let ctyp = prod_applist mip.mind_nf_lc.(0) args in let cargs = List.map pi3 ((prod_assum ctyp)) in - if style <> Some false || has_nodep_prod ctyp then + if not (is_lax_conjunction style) || has_nodep_prod ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) else None else None + | _ -> None in + match res with + | Some (hdapp, args) when not onlybinary -> res + | Some (hdapp, [_; _]) -> res | _ -> None -let match_with_conjunction ?(strict=false) t = - match_with_one_constructor (Some strict) false t +let match_with_conjunction ?(strict=false) ?(onlybinary=false) t = + match_with_one_constructor (Some strict) onlybinary false t let match_with_record t = - match_with_one_constructor None false t + match_with_one_constructor None false false t -let is_conjunction ?(strict=false) t = - op2bool (match_with_conjunction ~strict t) +let is_conjunction ?(strict=false) ?(onlybinary=false) t = + op2bool (match_with_conjunction ~strict ~onlybinary t) let is_record t = op2bool (match_with_record t) let match_with_tuple t = - let t = match_with_one_constructor None true t in + let t = match_with_one_constructor None false true t in Option.map (fun (hd,l) -> let ind = destInd hd in - let (mib,mip) = Global.lookup_inductive ind in - let isrec = mis_is_recursive (ind,mib,mip) in + let (mib,mip) = Global.lookup_pinductive ind in + let isrec = mis_is_recursive (fst ind,mib,mip) in (hd,l,isrec)) t let is_tuple t = @@ -143,20 +150,20 @@ let is_tuple t = "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *) let test_strict_disjunction n lc = - array_for_all_i (fun i c -> + Array.for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with - | [_,None,c] -> isRel c && destRel c = (n - i) + | [_,None,c] -> isRel c && Int.equal (destRel c) (n - i) | _ -> false) 0 lc -let match_with_disjunction ?(strict=false) t = +let match_with_disjunction ?(strict=false) ?(onlybinary=false) t = let (hdapp,args) = decompose_app t in - match kind_of_term hdapp with - | Ind ind -> - let car = mis_constr_nargs ind in + let res = match kind_of_term hdapp with + | Ind (ind,u) -> + let car = constructors_nrealargs ind in let (mib,mip) = Global.lookup_inductive ind in - if array_for_all (fun ar -> ar = 1) car - && not (mis_is_recursive (ind,mib,mip)) - && (mip.mind_nrealargs = 0) + if Array.for_all (fun ar -> Int.equal ar 1) car + && not (mis_is_recursive (ind,mib,mip)) + && (Int.equal mip.mind_nrealargs 0) then if strict then if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then @@ -170,10 +177,14 @@ let match_with_disjunction ?(strict=false) t = Some (hdapp,Array.to_list cargs) else None + | _ -> None in + match res with + | Some (hdapp,args) when not onlybinary -> res + | Some (hdapp,[_; _]) -> res | _ -> None -let is_disjunction ?(strict=false) t = - op2bool (match_with_disjunction ~strict t) +let is_disjunction ?(strict=false) ?(onlybinary=false) t = + op2bool (match_with_disjunction ~strict ~onlybinary t) (* An empty type is an inductive type, possible with indices, that has no constructors *) @@ -182,9 +193,9 @@ let match_with_empty_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in let nconstr = Array.length mip.mind_consnames in - if nconstr = 0 then Some hdapp else None + if Int.equal nconstr 0 then Some hdapp else None | _ -> None let is_empty_type t = op2bool (match_with_empty_type t) @@ -196,11 +207,11 @@ let match_with_unit_or_eq_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in - let zero_args c = nb_prod c = mib.mind_nparams in - if nconstr = 1 && zero_args constr_types.(0) then + let zero_args c = Int.equal (nb_prod c) mib.mind_nparams in + if Int.equal nconstr 1 && zero_args constr_types.(0) then Some hdapp else None @@ -214,7 +225,7 @@ let is_unit_or_eq_type t = op2bool (match_with_unit_or_eq_type t) let is_unit_type t = match match_with_conjunction t with - | Some (_,t) when List.length t = 0 -> true + | Some (_,[]) -> true | _ -> false (* Checks if a given term is an application of an @@ -232,27 +243,30 @@ let coq_refl_leibniz1_pattern = PATTERN [ forall x:_, _ x x ] let coq_refl_leibniz2_pattern = PATTERN [ forall A:_, forall x:A, _ A x x ] let coq_refl_jm_pattern = PATTERN [ forall A:_, forall x:A, _ A x A x ] -open Libnames +open Globnames + +let is_matching x y = is_matching (Global.env ()) Evd.empty x y +let matches x y = matches (Global.env ()) Evd.empty x y let match_with_equation t = if not (isApp t) then raise NoEquationFound; let (hdapp,args) = destApp t in match kind_of_term hdapp with - | Ind ind -> - if IndRef ind = glob_eq then + | Ind (ind,u) -> + if eq_gr (IndRef ind) glob_eq then Some (build_coq_eq_data()),hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if IndRef ind = glob_identity then + else if eq_gr (IndRef ind) glob_identity then Some (build_coq_identity_data()),hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if IndRef ind = glob_jmeq then + else if eq_gr (IndRef ind) glob_jmeq then Some (build_coq_jmeq_data()),hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) else let (mib,mip) = Global.lookup_inductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in - if nconstr = 1 then + if Int.equal nconstr 1 then if is_matching coq_refl_leibniz1_pattern constr_types.(0) then None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) else if is_matching coq_refl_leibniz2_pattern constr_types.(0) then @@ -263,25 +277,41 @@ let match_with_equation t = else raise NoEquationFound | _ -> raise NoEquationFound +(* Note: An "equality type" is any type with a single argument-free + constructor: it captures eq, eq_dep, JMeq, eq_true, etc. but also + True/unit which is the degenerate equality type (isomorphic to ()=()); + in particular, True/unit are provable by "reflexivity" *) + let is_inductive_equality ind = let (mib,mip) = Global.lookup_inductive ind in let nconstr = Array.length mip.mind_consnames in - nconstr = 1 && constructor_nrealargs (Global.env()) (ind,1) = 0 + Int.equal nconstr 1 && Int.equal (constructor_nrealargs (ind,1)) 0 let match_with_equality_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind when is_inductive_equality ind -> Some (hdapp,args) + | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args) | _ -> None let is_equality_type t = op2bool (match_with_equality_type t) +(* Arrows/Implication/Negation *) + let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ] let match_arrow_pattern t = - match matches coq_arrow_pattern t with - | [(m1,arg);(m2,mind)] -> assert (m1=meta1 & m2=meta2); (arg, mind) - | _ -> anomaly "Incorrect pattern matching" + let result = matches coq_arrow_pattern t in + match Id.Map.bindings result with + | [(m1,arg);(m2,mind)] -> + assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind) + | _ -> anomaly (Pp.str "Incorrect pattern matching") + +let match_with_imp_term c= + match kind_of_term c with + | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b) + | _ -> None + +let is_imp_term c = op2bool (match_with_imp_term c) let match_with_nottype t = try @@ -291,6 +321,8 @@ let match_with_nottype t = let is_nottype t = op2bool (match_with_nottype t) +(* Forall *) + let match_with_forall_term c= match kind_of_term c with | Prod (nam,a,b) -> Some (nam,a,b) @@ -298,24 +330,17 @@ let match_with_forall_term c= let is_forall_term c = op2bool (match_with_forall_term c) -let match_with_imp_term c= - match kind_of_term c with - | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b) - | _ -> None - -let is_imp_term c = op2bool (match_with_imp_term c) - let match_with_nodep_ind t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_pinductive ind in if Array.length (mib.mind_packets)>1 then None else let nodep_constr = has_nodep_prod_after mib.mind_nparams in - if array_for_all nodep_constr mip.mind_nf_lc then + if Array.for_all nodep_constr mip.mind_nf_lc then let params= - if mip.mind_nrealargs=0 then args else - fst (list_chop mib.mind_nparams args) in + if Int.equal mip.mind_nrealargs 0 then args else + fst (List.chop mib.mind_nparams args) in Some (hdapp,params,mip.mind_nrealargs) else None @@ -327,10 +352,10 @@ let match_with_sigma_type t= let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in - if (Array.length (mib.mind_packets)=1) && - (mip.mind_nrealargs=0) && - (Array.length mip.mind_consnames=1) && + let (mib,mip) = Global.lookup_pinductive ind in + if Int.equal (Array.length (mib.mind_packets)) 1 && + (Int.equal mip.mind_nrealargs 0) && + (Int.equal (Array.length mip.mind_consnames)1) && has_nodep_prod_after (mib.mind_nparams+1) mip.mind_nf_lc.(0) then (*allowing only 1 existential*) Some (hdapp,args) @@ -344,9 +369,10 @@ let is_sigma_type t=op2bool (match_with_sigma_type t) let rec first_match matcher = function | [] -> raise PatternMatchingFailure - | (pat,build_set)::l -> - try (build_set (),matcher pat) - with PatternMatchingFailure -> first_match matcher l + | (pat,check,build_set)::l when check () -> + (try (build_set (),matcher pat) + with PatternMatchingFailure -> first_match matcher l) + | _::l -> first_match matcher l (*** Equality *) @@ -355,50 +381,48 @@ let coq_eq_pattern_gen eq = lazy PATTERN [ %eq ?X1 ?X2 ?X3 ] let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref let coq_identity_pattern = coq_eq_pattern_gen coq_identity_ref let coq_jmeq_pattern = lazy PATTERN [ %coq_jmeq_ref ?X1 ?X2 ?X3 ?X4 ] -let coq_eq_true_pattern = lazy PATTERN [ %coq_eq_true_ref ?X1 ] let match_eq eqn eq_pat = let pat = try Lazy.force eq_pat with e when Errors.noncritical e -> raise PatternMatchingFailure in - match matches pat eqn with + match Id.Map.bindings (matches pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> - assert (m1 = meta1 & m2 = meta2 & m3 = meta3); - PolymorphicLeibnizEq (t,x,y) + assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); + PolymorphicLeibnizEq (t,x,y) | [(m1,t);(m2,x);(m3,t');(m4,x')] -> - assert (m1 = meta1 & m2 = meta2 & m3 = meta3 & m4 = meta4); + assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4); HeterogenousEq (t,x,t',x') - | _ -> anomaly "match_eq: an eq pattern should match 3 or 4 terms" + | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 or 4 terms") + +let no_check () = true +let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module let equalities = - [coq_eq_pattern, build_coq_eq_data; - coq_jmeq_pattern, build_coq_jmeq_data; - coq_identity_pattern, build_coq_identity_data] + [coq_eq_pattern, no_check, build_coq_eq_data; + coq_jmeq_pattern, check_jmeq_loaded, build_coq_jmeq_data; + coq_identity_pattern, no_check, build_coq_identity_data] let find_eq_data eqn = (* fails with PatternMatchingFailure *) - first_match (match_eq eqn) equalities + let d,k = first_match (match_eq eqn) equalities in + let hd,u = destInd (fst (destApp eqn)) in + d,u,k let extract_eq_args gl = function | MonomorphicLeibnizEq (e1,e2) -> - let t = Tacmach.pf_type_of gl e1 in (t,e1,e2) + let t = pf_type_of gl e1 in (t,e1,e2) | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2) | HeterogenousEq (t1,e1,t2,e2) -> - if Tacmach.pf_conv_x gl t1 t2 then (t1,e1,e2) + if pf_conv_x gl t1 t2 then (t1,e1,e2) else raise PatternMatchingFailure let find_eq_data_decompose gl eqn = - let (lbeq,eq_args) = find_eq_data eqn in - (lbeq,extract_eq_args gl eq_args) - -let inversible_equalities = - [coq_eq_pattern, build_coq_inversion_eq_data; - coq_jmeq_pattern, build_coq_inversion_jmeq_data; - coq_identity_pattern, build_coq_inversion_identity_data; - coq_eq_true_pattern, build_coq_inversion_eq_true_data] + let (lbeq,u,eq_args) = find_eq_data eqn in + (lbeq,u,extract_eq_args gl eq_args) let find_this_eq_data_decompose gl eqn = - let (lbeq,eq_args) = + let (lbeq,u,eq_args) = try (*first_match (match_eq eqn) inversible_equalities*) find_eq_data eqn with PatternMatchingFailure -> @@ -407,17 +431,14 @@ let find_this_eq_data_decompose gl eqn = try extract_eq_args gl eq_args with PatternMatchingFailure -> error "Don't know what to do with JMeq on arguments not of same type." in - (lbeq,eq_args) - -open Tacmach -open Tacticals + (lbeq,u,eq_args) let match_eq_nf gls eqn eq_pat = - match pf_matches gls (Lazy.force eq_pat) eqn with + match Id.Map.bindings (pf_matches gls (Lazy.force eq_pat) eqn) with | [(m1,t);(m2,x);(m3,y)] -> - assert (m1 = meta1 & m2 = meta2 & m3 = meta3); + assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); (t,pf_whd_betadeltaiota gls x,pf_whd_betadeltaiota gls y) - | _ -> anomaly "match_eq: an eq pattern should match 3 terms" + | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms") let dest_nf_eq gls eqn = try @@ -427,31 +448,24 @@ let dest_nf_eq gls eqn = (*** Sigma-types *) -(* 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 - | [(m1,a);(m2,p);(m3,car);(m4,cdr)] -> - assert (m1=meta1 & m2=meta2 & m3=meta3 & m4=meta4); - (a,p,car,cdr) - | _ -> - anomaly "match_sigma: a successful sigma pattern should match 4 terms" - +let match_sigma ex = + match kind_of_term ex with + | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_exist_ref) f -> + build_sigma (), (snd (destConstruct f), a, p, car, cdr) + | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_existT_ref) f -> + build_sigma_type (), (snd (destConstruct f), a, p, car, cdr) + | _ -> raise PatternMatchingFailure + let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) - first_match (match_sigma ex) - [coq_existT_pattern, build_sigma_type; - coq_exist_pattern, build_sigma] + match_sigma ex (* Pattern "(sig ?1 ?2)" *) let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ] let match_sigma t = - match matches (Lazy.force coq_sig_pattern) t with + match Id.Map.bindings (matches (Lazy.force coq_sig_pattern) t) with | [(_,a); (_,p)] -> (a,p) - | _ -> anomaly "Unexpected pattern" + | _ -> anomaly (Pp.str "Unexpected pattern") let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t @@ -486,10 +500,10 @@ let match_eqdec t = try true,op_or,matches (Lazy.force coq_eqdec_pattern) t with PatternMatchingFailure -> false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in - match subst with + match Id.Map.bindings subst with | [(_,typ);(_,c1);(_,c2)] -> - eqonleft, Libnames.constr_of_global (Lazy.force op), c1, c2, typ - | _ -> anomaly "Unexpected pattern" + eqonleft, Universes.constr_of_global (Lazy.force op), c1, c2, typ + | _ -> anomaly (Pp.str "Unexpected pattern") (* Patterns "~ ?" and "? -> False" *) let coq_not_pattern = lazy PATTERN [ ~ _ ] diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 31dd0361..c200871e 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -1,17 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (constr * constr list) matching_function -val is_disjunction : ?strict:bool -> testing_function +val match_with_disjunction : ?strict:bool -> ?onlybinary:bool -> (constr * constr list) matching_function +val is_disjunction : ?strict:bool -> ?onlybinary:bool -> testing_function (** 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 +val match_with_conjunction : ?strict:bool -> ?onlybinary:bool -> (constr * constr list) matching_function +val is_conjunction : ?strict:bool -> ?onlybinary:bool -> testing_function (** Non recursive tuple, possibly with inner dependencies *) val match_with_record : (constr * constr list) matching_function @@ -87,7 +84,7 @@ val is_equality_type : testing_function val match_with_nottype : (constr * constr) matching_function val is_nottype : testing_function -val match_with_forall_term : (name * constr * constr) matching_function +val match_with_forall_term : (Name.t * constr * constr) matching_function val is_forall_term : testing_function val match_with_imp_term : (constr * constr) matching_function @@ -123,20 +120,20 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) -val find_eq_data_decompose : Proof_type.goal sigma -> constr -> - coq_eq_data * (types * constr * constr) +val find_eq_data_decompose : [ `NF ] Proofview.Goal.t -> constr -> + coq_eq_data * Univ.universe_instance * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) -val find_this_eq_data_decompose : Proof_type.goal sigma -> constr -> - coq_eq_data * (types * constr * constr) +val find_this_eq_data_decompose : [ `NF ] Proofview.Goal.t -> constr -> + coq_eq_data * Univ.universe_instance * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) -val find_eq_data : constr -> coq_eq_data * equation_kind +val find_eq_data : constr -> coq_eq_data * Univ.universe_instance * equation_kind (** Match a term of the form [(existT A P t p)] Returns associated lemmas and [A,P,t,p] *) val find_sigma_data_decompose : constr -> - coq_sigma_data * (constr * constr * constr * constr) + coq_sigma_data * (Univ.universe_instance * constr * constr * constr * constr) (** Match a term of the form [{x:A|P}], returns [A] and [P] *) val match_sigma : constr -> constr * constr @@ -150,7 +147,7 @@ val match_eqdec : constr -> bool * constr * constr * constr * constr (** 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) +val dest_nf_eq : [ `NF ] Proofview.Goal.t -> constr -> (constr * constr * constr) (** Match a negation *) val is_matching_not : constr -> bool diff --git a/tactics/inv.ml b/tactics/inv.ml index 73edaf86..5502356f 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -1,63 +1,40 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mv::acc - | _ -> fold_constr collrec acc c - in - collrec [] c - -let check_no_metas clenv ccl = - if occur_meta ccl then - let metas = List.filter (fun m -> not (Evd.meta_defined clenv.evd m)) - (collect_meta_variables ccl) in - let metas = List.map (Evd.meta_name clenv.evd) metas in - errorlabstrm "inversion" - (str ("Cannot find an instantiation for variable"^ - (if List.length metas = 1 then " " else "s ")) ++ - prlist_with_sep pr_comma pr_name metas - (* ajouter "in " ++ pr_lconstr ccl mais il faut le bon contexte *)) +let clear hyps = Proofview.V82.tactic (clear hyps) let var_occurs_in_pf gl id = - let env = pf_env gl in - occur_var env id (pf_concl gl) or - List.exists (occur_var_in_decl env id) (pf_hyps gl) + let env = Proofview.Goal.env gl in + occur_var env id (Proofview.Goal.concl gl) || + List.exists (occur_var_in_decl env id) (Proofview.Goal.hyps gl) (* [make_inv_predicate (ity,args) C] @@ -88,16 +65,16 @@ let var_occurs_in_pf gl id = type inversion_status = Dep of constr option | NoDep let compute_eqn env sigma n i ai = - (ai, (mkRel (n-i),get_type_of env sigma (mkRel (n-i)))) + (mkRel (n-i),get_type_of env sigma (mkRel (n-i))) -let make_inv_predicate env sigma indf realargs id status concl = +let make_inv_predicate env evd indf realargs id status concl = let nrealargs = List.length realargs in let (hyps,concl) = match status with | NoDep -> (* We push the arity and leave concl unchanged *) let hyps_arity,_ = get_arity env indf in - (hyps_arity,concl) + (hyps_arity,concl) | Dep dflt_concl -> if not (occur_var env id concl) then errorlabstrm "make_inv_predicate" @@ -109,41 +86,53 @@ let make_inv_predicate env sigma indf realargs id status concl = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> - let sort = get_sort_family_of env sigma concl in - let p = make_arity env true indf (new_sort_in_family sort) in - Unification.abstract_list_all env (Evd.create_evar_defs sigma) - p concl (realargs@[mkVar id]) in + let sort = get_sort_family_of env !evd concl in + let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in + let p = make_arity env true indf sort in + let evd',(p,ptyp) = Unification.abstract_list_all env + !evd p concl (realargs@[mkVar id]) + in evd := evd'; p in let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) in let nhyps = rel_context_length hyps in let env' = push_rel_context hyps env in - let realargs' = List.map (lift nhyps) realargs in - let pairs = list_map_i (compute_eqn env' sigma nhyps) 0 realargs' in (* Now the arity is pushed, and we need to construct the pairs * ai,mkRel(n-i+1) *) (* Now, we can recurse down this list, for each ai,(mkRel k) whether to push (mkRel k)=ai (when Ai is closed). In any case, we carry along the rest of pairs *) - let rec build_concl eqns n = function - | [] -> (it_mkProd concl eqns,n) - | (ai,(xi,ti))::restlist -> + let eqdata = Coqlib.build_coq_eq_data () in + let rec build_concl eqns args n = function + | [] -> it_mkProd concl eqns, Array.rev_of_list args + | ai :: restlist -> + let ai = lift nhyps ai in + let (xi, ti) = compute_eqn env' !evd nhyps n ai in let (lhs,eqnty,rhs) = if closed0 ti then (xi,ti,ai) else - make_iterated_tuple env' sigma ai (xi,ti) + let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in + evd := sigma; res in - let eq_term = Coqlib.build_coq_eq () in - let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in - build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist + let eq_term = eqdata.Coqlib.eq in + let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in + let eqn = applist (eq,[eqnty;lhs;rhs]) in + let eqns = (Anonymous, lift n eqn) :: eqns in + let refl_term = eqdata.Coqlib.refl in + let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in + let refl = mkApp (refl_term, [|eqnty; rhs|]) in + let _ = Evarutil.evd_comb1 (Typing.e_type_of env) evd refl in + let args = refl :: args in + build_concl eqns args (succ n) restlist in - let (newconcl,neqns) = build_concl [] 0 pairs in + let (newconcl, args) = build_concl [] [] 0 realargs in let predicate = it_mkLambda_or_LetIn_name env newconcl hyps in + let _ = Evarutil.evd_comb1 (Typing.e_type_of env) evd predicate in (* OK - this predicate should now be usable by res_elimination_then to do elimination on the conclusion. *) - (predicate,neqns) + predicate, args (* The result of the elimination is a bunch of goals like: @@ -189,13 +178,13 @@ let make_inv_predicate env sigma indf realargs id status concl = and introduces generalized hypotheis. Precondition: t=(mkVar id) *) -let rec dependent_hyps id idlist gl = +let dependent_hyps env id idlist gl = let rec dep_rec =function | [] -> [] | (id1,_,_)::l -> (* Update the type of id1: it may have been subject to rewriting *) - let d = pf_get_hyp gl id1 in - if occur_var_in_decl (Global.env()) id d + let d = pf_get_hyp id1 gl in + if occur_var_in_decl env id d then d :: dep_rec l else dep_rec l in @@ -207,8 +196,6 @@ let split_dep_and_nodep hyps gl = if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2)) hyps ([],[]) -open Coqlib - (* Computation of dids is late; must have been done in rewrite_equations*) (* Will keep generalizing and introducing back and forth... *) (* Moreover, others hyps depending of dids should have been *) @@ -280,21 +267,62 @@ Summary: nine useless hypotheses! Nota: with Inversion_clear, only four useless hypotheses *) -let generalizeRewriteIntros tac depids id gls = - let dids = dependent_hyps id depids gls in - (tclTHENSEQ +let generalizeRewriteIntros as_mode tac depids id = + Proofview.tclENV >>= fun env -> + Proofview.Goal.nf_enter begin fun gl -> + let dids = dependent_hyps env id depids gl in + let reintros = if as_mode then intros_replacing else intros_possibly_replacing in + (tclTHENLIST [bring_hyps dids; tac; (* may actually fail to replace if dependent in a previous eq *) - intros_replacing (ids_of_named_context dids)]) - gls - -let rec tclMAP_i n tacfun = function - | [] -> tclDO n (tacfun None) - | a::l -> - if n=0 then error "Too many names." - else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l) + reintros (ids_of_named_context dids)]) + end + +let error_too_many_names pats = + let loc = Loc.join_loc (fst (List.hd pats)) (fst (List.last pats)) in + Proofview.tclENV >>= fun env -> + tclZEROMSG ~loc ( + str "Unexpected " ++ + str (String.plural (List.length pats) "introduction pattern") ++ + str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (snd (c env Evd.empty)))) pats ++ + str ".") + +let rec get_names (allow_conj,issimple) (loc,pat as x) = match pat with + | IntroNaming IntroAnonymous | IntroForthcoming _ -> + error "Anonymous pattern not allowed for inversion equations." + | IntroNaming (IntroFresh _) -> + error "Fresh pattern not allowed for inversion equations." + | IntroAction IntroWildcard -> + error "Discarding pattern not allowed for inversion equations." + | IntroAction (IntroRewrite _) -> + error "Rewriting pattern not allowed for inversion equations." + | IntroAction (IntroOrAndPattern [[]]) when allow_conj -> (None, []) + | IntroAction (IntroOrAndPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l]) + when allow_conj -> (Some id,l) + | IntroAction (IntroOrAndPattern [_]) -> + if issimple then + error"Conjunctive patterns not allowed for simple inversion equations." + else + error"Nested conjunctive patterns not allowed for inversion equations." + | IntroAction (IntroInjection l) -> + error "Injection patterns not allowed for inversion equations." + | IntroAction (IntroOrAndPattern l) -> + error "Disjunctive patterns not allowed for inversion equations." + | IntroAction (IntroApplyOn (c,pat)) -> + error "Apply patterns not allowed for inversion equations." + | IntroNaming (IntroIdentifier id) -> + (Some id,[x]) + +let rec tclMAP_i allow_conj n tacfun = function + | [] -> tclDO n (tacfun (None,[])) + | a::l as l' -> + if Int.equal n 0 then error_too_many_names l' + else + tclTHEN + (tacfun (get_names allow_conj a)) + (tclMAP_i allow_conj (n-1) tacfun l) -let remember_first_eq id x = if !x = no_move then x := MoveAfter id +let remember_first_eq id x = if !x == MoveLast then x := MoveAfter id (* invariant: ProjectAndApply is responsible for erasing the clause which it is given as input @@ -304,217 +332,177 @@ let remember_first_eq id x = if !x = no_move then x := MoveAfter id If it can discriminate then the goal is proved, if not tries to use it as a rewrite rule. It erases the clause which is given as input *) -let projectAndApply thin id eqname names depids gls = +let projectAndApply as_mode thin avoid id eqname names depids = let subst_hyp l2r id = tclTHEN (tclTRY(rewriteInConcl l2r (mkVar id))) (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC)) in - let substHypIfVariable tac id gls = - let (t,t1,t2) = Hipattern.dest_nf_eq gls (pf_get_hyp_typ gls id) in + let substHypIfVariable tac id = + Proofview.Goal.nf_enter begin fun gl -> + (** We only look at the type of hypothesis "id" *) + let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in + let (t,t1,t2) = Hipattern.dest_nf_eq gl hyp in match (kind_of_term t1, kind_of_term t2) with - | Var id1, _ -> generalizeRewriteIntros (subst_hyp true id) depids id1 gls - | _, Var id2 -> generalizeRewriteIntros (subst_hyp false id) depids id2 gls - | _ -> tac id gls + | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 + | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 + | _ -> tac id + end in - let deq_trailer id neqns = - tclTHENSEQ - [(if names <> [] then clear [id] else tclIDTAC); - (tclMAP_i neqns (fun idopt -> + let deq_trailer id clear_flag _ neqns = + assert (clear_flag == None); + tclTHENLIST + [if as_mode then clear [id] else tclIDTAC; + (tclMAP_i (false,false) neqns (function (idopt,_) -> tclTRY (tclTHEN - (intro_move idopt no_move) + (intro_move_avoid idopt avoid MoveLast) (* try again to substitute and if still not a variable after *) (* decomposition, arbitrarily try to rewrite RL !? *) - (tclTRY (onLastHypId (substHypIfVariable (subst_hyp false)))))) + (tclTRY (onLastHypId (substHypIfVariable (fun id -> subst_hyp false id)))))) names); - (if names = [] then clear [id] else tclIDTAC)] + (if as_mode then tclIDTAC else clear [id])] + (* Doing the above late breaks the computation of dids in + generalizeRewriteIntros, and hence breaks proper intros_replacing + but it is needed for compatibility *) in substHypIfVariable (* If no immediate variable in the equation, try to decompose it *) (* and apply a trailer which again try to substitute *) (fun id -> dEqThen false (deq_trailer id) - (Some (ElimOnConstr (mkVar id,NoBindings)))) + (Some (None,ElimOnConstr (mkVar id,NoBindings)))) id - gls - -(* Inversion qui n'introduit pas les hypotheses, afin de pouvoir les nommer - soi-meme (proposition de Valerie). *) -let rewrite_equations_gene othin neqns ba gl = - let (depids,nodepids) = split_dep_and_nodep ba.assums gl in - let rewrite_eqns = - match othin with - | Some thin -> - onLastHypId - (fun last -> - tclTHENSEQ - [tclDO neqns - (tclTHEN intro - (onLastHypId - (fun id -> - tclTRY - (projectAndApply thin id (ref no_move) - [] depids)))); - onHyps (compose List.rev (afterHyp last)) bring_hyps; - onHyps (afterHyp last) - (compose clear ids_of_named_context)]) - | None -> tclIDTAC - in - (tclTHENSEQ - [tclDO neqns intro; - bring_hyps nodepids; - clear (ids_of_named_context nodepids); - onHyps (compose List.rev (nLastDecls neqns)) bring_hyps; - onHyps (nLastDecls neqns) (compose clear ids_of_named_context); - rewrite_eqns; - tclMAP (fun (id,_,_ as d) -> - (tclORELSE (clear [id]) - (tclTHEN (bring_hyps [d]) (clear [id])))) - depids]) - gl + +let nLastDecls i tac = + Proofview.Goal.nf_enter (fun gl -> tac (nLastDecls gl i)) (* Introduction of the equations on arguments othin: discriminates Simple Inversion, Inversion and Inversion_clear None: the equations are introduced, but not rewritten Some thin: the equations are rewritten, and cleared if thin is true *) -let rec get_names allow_conj (loc,pat) = match pat with - | IntroWildcard -> - error "Discarding pattern not allowed for inversion equations." - | IntroAnonymous | IntroForthcoming _ -> - error "Anonymous pattern not allowed for inversion equations." - | IntroFresh _ -> - error "Fresh pattern not allowed for inversion equations." - | IntroRewrite _-> - error "Rewriting pattern not allowed for inversion equations." - | IntroOrAndPattern [l] -> - if allow_conj then - if l = [] then (None,[]) else - let l = List.map (fun id -> Option.get (fst (get_names false id))) l in - (Some (List.hd l), l) - else - error"Nested conjunctive patterns not allowed for inversion equations." - | IntroOrAndPattern l -> - error "Disjunctive patterns not allowed for inversion equations." - | IntroIdentifier id -> - (Some id,[id]) - -let extract_eqn_names = function - | None -> None,[] - | Some x -> x - -let rewrite_equations othin neqns names ba gl = - let names = List.map (get_names true) names in - let (depids,nodepids) = split_dep_and_nodep ba.assums gl in - let rewrite_eqns = - let first_eq = ref no_move in - match othin with - | Some thin -> - tclTHENSEQ - [onHyps (compose List.rev (nLastDecls neqns)) bring_hyps; - onHyps (nLastDecls neqns) (compose clear ids_of_named_context); - tclMAP_i neqns (fun o -> - let idopt,names = extract_eqn_names o in +let rewrite_equations as_mode othin neqns names ba = + Proofview.Goal.nf_enter begin fun gl -> + let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in + let first_eq = ref MoveLast in + let avoid = if as_mode then List.map pi1 nodepids else [] in + match othin with + | Some thin -> + tclTHENLIST + [tclDO neqns intro; + bring_hyps nodepids; + clear (ids_of_named_context nodepids); + (nLastDecls neqns (fun ctx -> bring_hyps (List.rev ctx))); + (nLastDecls neqns (fun ctx -> clear (ids_of_named_context ctx))); + tclMAP_i (true,false) neqns (fun (idopt,names) -> (tclTHEN - (intro_move idopt no_move) + (intro_move_avoid idopt avoid MoveLast) (onLastHypId (fun id -> - tclTRY (projectAndApply thin id first_eq names depids))))) + tclTRY (projectAndApply as_mode thin avoid id first_eq names depids))))) names; - tclMAP (fun (id,_,_) gl -> - intro_move None (if thin then no_move else !first_eq) gl) + tclMAP (fun (id,_,_) -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) + let idopt = if as_mode then Some id else None in + intro_move idopt (if thin then MoveLast else !first_eq)) nodepids; - tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids] - | None -> tclIDTAC - in - (tclTHENSEQ - [tclDO neqns intro; - bring_hyps nodepids; - clear (ids_of_named_context nodepids); - rewrite_eqns]) - gl + (tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids)] + | None -> + (* simple inversion *) + if as_mode then + tclMAP_i (false,true) neqns (fun (idopt,_) -> + intro_move idopt MoveLast) names + else + (tclTHENLIST + [tclDO neqns intro; + bring_hyps nodepids; + clear (ids_of_named_context nodepids)]) + end let interp_inversion_kind = function | SimpleInversion -> None | FullInversion -> Some false | FullInversionClear -> Some true -let rewrite_equations_tac (gene, othin) id neqns names ba = +let rewrite_equations_tac as_mode othin id neqns names ba = let othin = interp_inversion_kind othin in - let tac = - if gene then rewrite_equations_gene othin neqns ba - else rewrite_equations othin neqns names ba in - if othin = Some true (* if Inversion_clear, clear the hypothesis *) then + let tac = rewrite_equations as_mode othin neqns names ba in + match othin with + | Some true (* if Inversion_clear, clear the hypothesis *) -> tclTHEN tac (tclTRY (clear [id])) - else + | _ -> tac - -let raw_inversion inv_kind id status names gl = - let env = pf_env gl and sigma = project gl in - let c = mkVar id in - let (ind,t) = - try pf_reduce_to_atomic_ind gl (pf_type_of gl c) - with UserError _ -> - errorlabstrm "raw_inversion" - (str ("The type of "^(string_of_id id)^" is not inductive.")) in - let indclause = mk_clenv_from gl (c,t) in - let ccl = clenv_type indclause in - check_no_metas indclause ccl; - let IndType (indf,realargs) = find_rectype env sigma ccl in - let (elim_predicate,neqns) = - make_inv_predicate env sigma indf realargs id status (pf_concl gl) in - let (cut_concl,case_tac) = - if status <> NoDep & (dependent c (pf_concl gl)) then - Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), - case_then_using - else - Reduction.beta_appvect elim_predicate (Array.of_list realargs), - case_nodep_then_using - in - (tclTHENS - (assert_tac Anonymous cut_concl) - [case_tac names - (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns)) - (Some elim_predicate) ([],[]) ind indclause; - onLastHypId - (fun id -> - (tclTHEN - (apply_term (mkVar id) - (list_tabulate (fun _ -> Evarutil.mk_new_meta()) neqns)) - reflexivity))]) - gl +let raw_inversion inv_kind id status names = + Proofview.Goal.nf_enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let c = mkVar id in + let (ind, t) = + try pf_apply Tacred.reduce_to_atomic_ind gl (pf_type_of gl c) + with UserError _ -> + let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in + Errors.errorlabstrm "" msg + in + let IndType (indf,realargs) = find_rectype env sigma t in + let evdref = ref sigma in + let (elim_predicate, args) = + make_inv_predicate env evdref indf realargs id status concl in + let sigma = !evdref in + let (cut_concl,case_tac) = + if status != NoDep && (dependent c concl) then + Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), + case_then_using + else + Reduction.beta_appvect elim_predicate (Array.of_list realargs), + case_nodep_then_using + in + let refined id = + let prf = mkApp (mkVar id, args) in + Proofview.Refine.refine (fun h -> h, prf) + in + let neqns = List.length realargs in + let as_mode = names != None in + tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (tclTHENS + (assert_before Anonymous cut_concl) + [case_tac names + (introCaseAssumsThen + (rewrite_equations_tac as_mode inv_kind id neqns)) + (Some elim_predicate) ind (c, t); + onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) + end (* Error messages of the inversion tactics *) -let wrap_inv_error id = function +let wrap_inv_error id = function (e, info) -> match e with | Indrec.RecursionSchemeError (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) -> - errorlabstrm "" + Proofview.tclENV >>= fun env -> + tclZEROMSG ( (strbrk "Inversion would require case analysis on sort " ++ - pr_sort k ++ + pr_sort Evd.empty k ++ strbrk " which is not allowed for inductive definition " ++ - pr_inductive (Global.env()) i ++ str ".") - | e -> raise e + pr_inductive env (fst i) ++ str ".")) + | e -> Proofview.tclZERO ~info e (* The most general inversion tactic *) -let inversion inv_kind status names id gls = - try (raw_inversion inv_kind id status names) gls - with e when Errors.noncritical e -> wrap_inv_error id e +let inversion inv_kind status names id = + Proofview.tclORELSE + (raw_inversion inv_kind id status names) + (wrap_inv_error id) (* Specializing it... *) -let inv_gen gene thin status names = - try_intros_until (inversion (gene,thin) status names) +let inv_gen thin status names = + try_intros_until (inversion thin status names) open Tacexpr -let inv k = inv_gen false k NoDep +let inv k = inv_gen k NoDep -let half_inv_tac id = inv SimpleInversion None (NamedHyp id) let inv_tac id = inv FullInversion None (NamedHyp id) let inv_clear_tac id = inv FullInversionClear None (NamedHyp id) -let dinv k c = inv_gen false k (Dep c) +let dinv k c = inv_gen k (Dep c) -let half_dinv_tac id = dinv SimpleInversion None None (NamedHyp id) let dinv_tac id = dinv FullInversion None None (NamedHyp id) let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) @@ -522,25 +510,30 @@ let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) * perform inversion on the named hypothesis. After, it will intro them * back to their places in the hyp-list. *) -let invIn k names ids id gls = - let hyps = List.map (pf_get_hyp gls) ids in - let nb_prod_init = nb_prod (pf_concl gls) in - let intros_replace_ids gls = - let nb_of_new_hyp = - nb_prod (pf_concl gls) - (List.length hyps + nb_prod_init) +let invIn k names ids id = + Proofview.Goal.nf_enter begin fun gl -> + let hyps = List.map (fun id -> pf_get_hyp id gl) ids in + let concl = Proofview.Goal.concl gl in + let nb_prod_init = nb_prod concl in + let intros_replace_ids = + Proofview.Goal.enter begin fun gl -> + let concl = pf_nf_concl gl in + let nb_of_new_hyp = + nb_prod concl - (List.length hyps + nb_prod_init) + in + if nb_of_new_hyp < 1 then + intros_replacing ids + else + tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) + end in - if nb_of_new_hyp < 1 then - intros_replacing ids gls - else - tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) gls - in - try - (tclTHENSEQ - [bring_hyps hyps; - inversion (false,k) NoDep names id; - intros_replace_ids]) - gls - with e when Errors.noncritical e -> wrap_inv_error id e + Proofview.tclORELSE + (tclTHENLIST + [bring_hyps hyps; + inversion k NoDep names id; + intros_replace_ids]) + (wrap_inv_error id) + end let invIn_gen k names idl = try_intros_until (invIn k names idl) diff --git a/tactics/inv.mli b/tactics/inv.mli index ca87e0fc..b3478dda 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -1,41 +1,30 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* inversion_kind -> inversion_status -> - intro_pattern_expr located option -> quantified_hypothesis -> tactic -val invIn_gen : - inversion_kind -> intro_pattern_expr located option -> identifier list -> - quantified_hypothesis -> tactic - val inv_clause : - inversion_kind -> intro_pattern_expr located option -> identifier list -> - quantified_hypothesis -> tactic + inversion_kind -> or_and_intro_pattern option -> Id.t list -> + quantified_hypothesis -> unit Proofview.tactic -val inv : inversion_kind -> intro_pattern_expr located option -> - quantified_hypothesis -> tactic +val inv : inversion_kind -> or_and_intro_pattern option -> + quantified_hypothesis -> unit Proofview.tactic val dinv : inversion_kind -> constr option -> - intro_pattern_expr located option -> quantified_hypothesis -> tactic + or_and_intro_pattern option -> quantified_hypothesis -> unit Proofview.tactic -val half_inv_tac : identifier -> tactic -val inv_tac : identifier -> tactic -val inv_clear_tac : identifier -> tactic -val half_dinv_tac : identifier -> tactic -val dinv_tac : identifier -> tactic -val dinv_clear_tac : identifier -> tactic +val inv_tac : Id.t -> unit Proofview.tactic +val inv_clear_tac : Id.t -> unit Proofview.tactic +val dinv_tac : Id.t -> unit Proofview.tactic +val dinv_clear_tac : Id.t -> unit Proofview.tactic diff --git a/tactics/leminv.ml b/tactics/leminv.ml index bae81df7..f00ecf8f 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -1,42 +1,36 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(*