diff options
Diffstat (limited to 'tactics')
58 files changed, 8939 insertions, 6329 deletions
diff --git a/tactics/auto.ml b/tactics/auto.ml index 36136a6c..99630417 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -6,14 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: auto.ml 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) open Pp open Util open Names open Nameops +open Namegen open Term open Termops +open Inductiveops open Sign open Environ open Inductive @@ -34,6 +36,7 @@ open Clenv open Hiddentac open Libnames open Nametab +open Smartlocate open Libobject open Library open Printer @@ -45,15 +48,15 @@ open Mod_subst (* The Type of Constructions Autotactic Hints *) (****************************************************************************) -type auto_tactic = +type auto_tactic = | Res_pf of constr * clausenv (* Hint Apply *) | ERes_pf of constr * clausenv (* Hint EApply *) - | Give_exact of constr + | Give_exact of constr | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) - | Extern of glob_tactic_expr (* Hint Extern *) + | Extern of glob_tactic_expr (* Hint Extern *) -type pri_auto_tactic = { +type pri_auto_tactic = { pri : int; (* A number between 0 and 4, 4 = lower priority *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) code : auto_tactic (* the tactic to apply when the concl matches pat *) @@ -61,19 +64,17 @@ type pri_auto_tactic = { type hint_entry = global_reference option * pri_auto_tactic -let pri_ord {pri=pri1} {pri=pri2} = pri1 - pri2 - let pri_order {pri=pri1} {pri=pri2} = pri1 <= pri2 -let insert v l = +let insert v l = let rec insrec = function | [] -> [v] | h::tl -> if pri_order v h then v::h::tl else h::(insrec tl) - in + in insrec l (* Nov 98 -- Papageno *) -(* Les Hints sont ré-organisés en plusieurs databases. +(* 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. @@ -89,150 +90,162 @@ let insert v l = type stored_data = pri_auto_tactic -type search_entry = stored_data list * stored_data list * stored_data Btermdn.t - -let empty_se = ([],[],Btermdn.create ()) +module Bounded_net = Btermdn.Make(struct + type t = stored_data + let compare = Pervasives.compare + 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.mem t l) then (insert t l, l', dn) else (l, l', dn) - | Some pat -> if not (List.mem t l') then (l, insert t l', Btermdn.add st dn (pat,t)) else (l, l', dn) + | 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) = - (l, l', List.fold_left (fun dn t -> Btermdn.add (Some st) dn (Option.get t.pat, t)) - (Btermdn.create ()) l') - + (l, l', List.fold_left (fun dn t -> Bounded_net.add (Some st) dn (Option.get t.pat, t)) + (Bounded_net.create ()) l') + let lookup_tacs (hdc,c) st (l,l',dn) = - let l' = List.map snd (Btermdn.lookup st dn c) in + let l' = List.map snd (Bounded_net.lookup st dn c) in let sl' = Sort.list pri_order l' in Sort.merge pri_order l sl' -module Constr_map = Map.Make(struct - type t = global_reference - let compare = Pervasives.compare - end) +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 fmt_autotactic = - function - | Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c) - | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c) - | Give_exact c -> (str"exact " ++ pr_lconstr c) - | Res_pf_THEN_trivial_fail (c,clenv) -> - (str"apply " ++ pr_lconstr c ++ str" ; trivial") - | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) - | Extern tac -> - (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) - -let pr_autotactic = fmt_autotactic module Hint_db = struct - type t = { + type t = { hintdb_state : Names.transparent_state; + hintdb_unfolds : Idset.t * Cset.t; 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 : stored_data list + hintdb_nopat : (global_reference option * stored_data) list } let empty st use_dn = { hintdb_state = st; + hintdb_unfolds = (Idset.empty, Cset.empty); 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 = - Sort.merge pri_order db.hintdb_nopat [] - + + let map_none db = + Sort.merge pri_order (List.map snd db.hintdb_nopat) [] + let map_all k db = let (l,l',_) = find k db in - Sort.merge pri_order (db.hintdb_nopat @ l) l' + Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l' let map_auto (k,c) db = let st = if db.use_dn then Some db.hintdb_state else None in let l' = lookup_tacs (k,c) st (find k db) in - Sort.merge pri_order db.hintdb_nopat l' - - let is_exact = function + Sort.merge pri_order (List.map snd db.hintdb_nopat) l' + + let is_exact = function | Give_exact _ -> true | _ -> false - let rebuild_db st' db = - { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map } - - let add_one (k,v) db = - let st',rebuild = - match v.code with - | Unfold_nth egr -> - let (ids,csts) = db.hintdb_state in - (match egr with - | EvalVarRef id -> (Idpred.add id ids, csts) - | EvalConstRef cst -> (ids, Cpred.add cst csts)), true - | _ -> db.hintdb_state, false - in - let dnst, db, k = - if db.use_dn then - let db', k' = - if rebuild then rebuild_db st' db, k - else (* not an unfold *) - (match k with - | Some gr -> db, if is_transparent_gr st' gr then None else k - | None -> db, None) - in - (Some st', db', k') - else None, db, k + let addkv gr v db = + let k = match gr with + | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr 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.mem v db.hintdb_nopat) then - { db with hintdb_nopat = v :: db.hintdb_nopat } + if not (List.exists (fun (_, v') -> v = v') db.hintdb_nopat) then + { db with hintdb_nopat = (gr,v) :: db.hintdb_nopat } else db | Some gr -> let oval = find gr db in - { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map; - hintdb_state = st' } - + { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map } + + let rebuild_db st' db = + let db' = + { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map; + hintdb_state = st'; hintdb_nopat = [] } + in + List.fold_left (fun db (gr,v) -> addkv gr v db) db' db.hintdb_nopat + + let add_one (k,v) db = + 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 v db + let add_list l db = List.fold_right add_one l db - - let iter f db = - f None db.hintdb_nopat; + + let iter f db = + f None (List.map snd db.hintdb_nopat); Constr_map.iter (fun k (l,l',_) -> f (Some k) (l@l')) db.hintdb_map - + let transparent_state db = db.hintdb_state let set_transparent_state db st = - let db = if db.use_dn then rebuild_db st db else db in - { db with hintdb_state = st } + if db.use_dn then rebuild_db st db + else { db with hintdb_state = st } + + 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 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 = + +let searchtable_map name = Hintdbmap.find name !searchtable -let searchtable_add (name,db) = +let searchtable_add (name,db) = searchtable := Hintdbmap.add name db !searchtable let current_db_names () = Hintdbmap.dom !searchtable @@ -242,7 +255,7 @@ let current_db_names () = (**************************************************************************) let auto_init : (unit -> unit) ref = ref (fun () -> ()) - + let init () = searchtable := Hintdbmap.empty; !auto_init () let freeze () = !searchtable let unfreeze fs = searchtable := fs @@ -250,52 +263,51 @@ let unfreeze fs = searchtable := fs let _ = Summary.declare_summary "search" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; - Summary.init_function = init; - Summary.survive_module = false; - Summary.survive_section = false } + 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 + | _ -> 0 (* adding and removing tactics in the search table *) -let try_head_pattern c = +let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable." -let dummy_goal = +let dummy_goal = {it = make_evar empty_named_context_val mkProp; sigma = empty} -let make_exact_entry pri (c,cty) = +let make_exact_entry sigma pri (c,cty) = let cty = strip_outer_cast cty in - match kind_of_term cty with - | Prod (_,_,_) -> - failwith "make_exact_entry" + match kind_of_term cty with + | Prod _ -> failwith "make_exact_entry" | _ -> - let ce = mk_clenv_from dummy_goal (c,cty) in - let c' = clenv_type ce in - let pat = Pattern.pattern_of_constr c' in - (Some (head_of_constr_reference (fst (head_constr cty))), - { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c }) + let pat = snd (Pattern.pattern_of_constr sigma cty) in + let head = + try head_of_constr_reference (fst (head_constr cty)) + with _ -> failwith "make_exact_entry" + in + (Some head, + { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c }) let make_apply_entry env sigma (eapply,hnf,verbose) pri (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 ce in - let pat = Pattern.pattern_of_constr c' 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 + if nmiss = 0 then (Some hd, { pri = (match pri with None -> nb_hyp cty | Some p -> p); pat = Some pat; @@ -311,43 +323,43 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) = code = ERes_pf(c,{ce with env=empty_env}) }) 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 + +(* 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 c = let cty = type_of env sigma c in - let ents = - map_succeed - (fun f -> f (c,cty)) - [make_exact_entry pri; make_apply_entry env sigma flags pri] - in + let ents = + map_succeed + (fun f -> f (c,cty)) + [make_exact_entry sigma pri; make_apply_entry env sigma flags pri] + in if ents = [] then - errorlabstrm "Hint" - (pr_lconstr c ++ spc() ++ + 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) = +let make_resolve_hyp env sigma (hname,_,htyp) = try [make_apply_entry env sigma (true, true, false) None (mkVar hname, htyp)] - with + with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly "make_resolve_hyp" (* REM : in most cases hintname = id *) -let make_unfold (ref, eref) = - (Some ref, +let make_unfold eref = + (Some (global_of_evaluable_reference eref), { pri = 4; pat = None; code = Unfold_nth eref }) -let make_extern pri pat tacast = - let hdconstr = Option.map try_head_pattern pat in +let make_extern pri pat tacast = + let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri=pri; pat = pat; @@ -358,7 +370,7 @@ let make_trivial env sigma c = 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 (Pattern.pattern_of_constr (clenv_type ce)); + pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce))); code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) }) open Vernacexpr @@ -369,52 +381,47 @@ open Vernacexpr (* 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 = - try - let db = searchtable_map dbname in - let db' = Hint_db.add_list hintlist db in + let db = get_db dbname in + let db' = Hint_db.add_list hintlist db in searchtable_add (dbname,db') - with Not_found -> - let db = Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false) in - searchtable_add (dbname,db) let add_transparency dbname grs b = - let db = searchtable_map dbname in + let db = get_db dbname in let st = Hint_db.transparent_state db in - let st' = - List.fold_left (fun (ids, csts) gr -> + 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') - + type hint_action = | CreateDB of bool * transparent_state | AddTransparency of evaluable_global_reference list * bool | AddTactic of (global_reference option * pri_auto_tactic) list -let cache_autohint (_,(local,name,hints)) = +let cache_autohint (_,(local,name,hints)) = match hints with | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) | AddTransparency (grs, b) -> add_transparency name grs b | AddTactic hints -> add_hint name hints -let forward_subst_tactic = +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_autohint (subst,(local,name,hintlist as obj)) = let trans_clenv clenv = Clenv.subst_clenv subst clenv in - let trans_data data code = - { data with - pat = Option.smartmap (subst_pattern subst) data.pat ; - code = code ; - } - in let subst_key gr = let (lab'', elab') = subst_global subst gr in - let gr' = + let gr' = (try head_of_constr_reference (fst (head_constr_bound elab')) with Tactics.Bound -> lab'') in if gr' == gr then gr else gr' @@ -424,61 +431,87 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) = let data' = match data.code with | Res_pf (c, clenv) -> let c' = subst_mps subst c in - if c==c' then data else - trans_data data (Res_pf (c', trans_clenv clenv)) + let clenv' = trans_clenv clenv in + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if c==c' && clenv'==clenv && pat'==data.pat then data else + {data with + pat=pat'; + code=Res_pf (c', clenv')} | ERes_pf (c, clenv) -> let c' = subst_mps subst c in - if c==c' then data else - trans_data data (ERes_pf (c', trans_clenv clenv)) + let clenv' = trans_clenv clenv in + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if c==c' && clenv'==clenv && pat'==data.pat then data else + {data with + pat=pat'; + code=ERes_pf (c', clenv')} | Give_exact c -> let c' = subst_mps subst c in - if c==c' then data else - trans_data data (Give_exact c') + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if c==c' && pat'==data.pat then data else + {data with + pat=pat'; + code=(Give_exact c')} | Res_pf_THEN_trivial_fail (c, clenv) -> let c' = subst_mps subst c in - if c==c' then data else - let code' = Res_pf_THEN_trivial_fail (c', trans_clenv clenv) in - trans_data data code' - | Unfold_nth ref -> + let clenv' = trans_clenv clenv in + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if c==c' && clenv'==clenv && pat'==data.pat then data else + {data with + pat=pat'; + code=Res_pf_THEN_trivial_fail (c',clenv')} + | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in - if ref==ref' then data else - trans_data data (Unfold_nth ref') + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if ref==ref' && pat'==data.pat then data else + {data with + pat=pat'; + code=(Unfold_nth ref')} | Extern tac -> let tac' = !forward_subst_tactic subst tac in - if tac==tac' then data else - trans_data data (Extern tac') + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if tac==tac' && pat'==data.pat then data else + {data with + pat=pat'; + code=(Extern tac')} in if k' == k && data' == data then hint else (k',data') in match hintlist with | CreateDB _ -> obj - | AddTransparency (grs, b) -> + | AddTransparency (grs, b) -> let grs' = list_smartmap (subst_evaluable_reference subst) grs in if grs==grs' then obj else (local, name, AddTransparency (grs', b)) | AddTactic hintlist -> let hintlist' = list_smartmap subst_hint hintlist in if hintlist' == hintlist then obj else (local,name,AddTactic hintlist') - -let classify_autohint (_,((local,name,hintlist) as obj)) = - if local or hintlist = (AddTactic []) then Dispose else Substitute obj -let export_autohint ((local,name,hintlist) as obj) = - if local then None else Some obj +let classify_autohint ((local,name,hintlist) as obj) = + if local or hintlist = (AddTactic []) then Dispose else Substitute obj -let (inAutoHint,outAutoHint) = +let discharge_autohint (_,(local,name,hintlist as obj)) = + if local then None else + match hintlist with + | CreateDB _ -> + (* We assume that the transparent state is either empty or full *) + Some obj + | AddTransparency _ | AddTactic _ -> + (* Needs the adequate code here to support Global Hints in sections *) + None + +let (inAutoHint,_) = declare_object {(default_object "AUTOHINT") with cache_function = cache_autohint; load_function = (fun _ -> cache_autohint); subst_function = subst_autohint; - classify_function = classify_autohint; - export_function = export_autohint } + classify_function = classify_autohint } -let create_hint_db l n st b = +let create_hint_db l n st b = Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st))) - + (**************************************************************************) (* The "Hint" vernacular command *) (**************************************************************************) @@ -494,14 +527,14 @@ let add_resolves env sigma clist local dbnames = let add_unfolds l local dbnames = - List.iter - (fun dbname -> Lib.add_anonymous_leaf + List.iter + (fun dbname -> Lib.add_anonymous_leaf (inAutoHint (local,dbname, AddTactic (List.map make_unfold l)))) dbnames let add_transparency l b local dbnames = - List.iter - (fun dbname -> Lib.add_anonymous_leaf + List.iter + (fun dbname -> Lib.add_anonymous_leaf (inAutoHint (local,dbname, AddTransparency (l, b)))) dbnames @@ -513,16 +546,16 @@ let add_extern pri pat tacast local dbname = | Some (patmetas,pat) -> (match (list_subtract tacmetas patmetas) with | i::_ -> - errorlabstrm "add_extern" - (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound.") + errorlabstrm "add_extern" + (str "The meta-variable ?" ++ Ppconstr.pr_patvar i ++ str" is not bound.") | [] -> Lib.add_anonymous_leaf (inAutoHint(local,dbname, AddTactic [make_extern pri (Some pat) tacast]))) - | None -> + | None -> Lib.add_anonymous_leaf (inAutoHint(local,dbname, AddTactic [make_extern pri None tacast])) -let add_externs pri pat tacast local dbnames = +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 = @@ -532,62 +565,61 @@ let add_trivials env sigma l local dbnames = inAutoHint(local,dbname, AddTactic (List.map (make_trivial env sigma) l)))) dbnames -let forward_intern_tac = +let forward_intern_tac = ref (fun _ -> failwith "intern_tac is not installed for auto") let set_extern_intern_tac f = forward_intern_tac := f -let add_hints local dbnames0 h = - let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in - let env = Global.env() and sigma = Evd.empty in - let f = Constrintern.interp_constr sigma env in +type hints_entry = + | HintsResolveEntry of (int option * bool * constr) list + | HintsImmediateEntry of constr list + | HintsUnfoldEntry of evaluable_global_reference list + | HintsTransparencyEntry of evaluable_global_reference list * bool + | HintsExternEntry of + int * (patvar list * constr_pattern) option * glob_tactic_expr + | HintsDestructEntry of identifier * int * (bool,unit) location * + (patvar list * constr_pattern) * glob_tactic_expr + +let interp_hints h = + let f = Constrintern.interp_constr Evd.empty (Global.env()) 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 fp = Constrintern.intern_constr_pattern Evd.empty (Global.env()) in match h with - | HintsResolve lhints -> - add_resolves env sigma (List.map (fun (pri, b, x) -> pri, b, f x) lhints) local dbnames - | HintsImmediate lhints -> - add_trivials env sigma (List.map f lhints) local dbnames - | HintsUnfold lhints -> - let f r = - let gr = Syntax_def.global_with_alias r in - let r' = match gr with - | ConstRef c -> EvalConstRef c - | VarRef c -> EvalVarRef c - | _ -> - errorlabstrm "evalref_of_ref" - (str "Cannot coerce" ++ spc () ++ pr_global gr ++ spc () ++ - str "to an evaluable reference.") - in - Dumpglob.add_glob (loc_of_reference r) gr; - (gr,r') in - add_unfolds (List.map f lhints) local dbnames - | HintsTransparency (lhints, b) -> - let f r = - let gr = Syntax_def.global_with_alias r in - let r' = match gr with - | ConstRef c -> EvalConstRef c - | VarRef c -> EvalVarRef c - | _ -> - errorlabstrm "evalref_of_ref" - (str "Cannot coerce" ++ spc () ++ pr_global gr ++ spc () ++ - str "to an evaluable reference.") - in - Dumpglob.add_glob (loc_of_reference r) gr; - r' in - add_transparency (List.map f lhints) b local dbnames + | HintsResolve lhints -> HintsResolveEntry (List.map (on_pi3 f) lhints) + | HintsImmediate lhints -> HintsImmediateEntry (List.map f lhints) + | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) + | HintsTransparency (lhints, b) -> + HintsTransparencyEntry (List.map fr lhints, b) | HintsConstructors lqid -> - let add_one qid = - let env = Global.env() and sigma = Evd.empty in - let isp = inductive_of_reference qid in - let consnames = (snd (Global.lookup_inductive isp)).mind_consnames in - let lcons = list_tabulate - (fun i -> None, true, mkConstruct (isp,i+1)) (Array.length consnames) in - add_resolves env sigma lcons local dbnames in - List.iter add_one lqid + let constr_hints_of_ind qid = + let ind = global_inductive_with_alias qid in + list_tabulate (fun i -> None, true, mkConstruct (ind,i+1)) + (nconstructors ind) in + HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> - let pat = Option.map (Constrintern.intern_constr_pattern Evd.empty (Global.env())) patcom in + let pat = Option.map fp patcom in let tacexp = !forward_intern_tac (match pat with None -> [] | Some (l, _) -> l) tacexp in - add_externs pri pat tacexp local dbnames + HintsExternEntry (pri, pat, tacexp) | HintsDestruct(na,pri,loc,pat,code) -> + let (l,_ as pat) = fp pat in + HintsDestructEntry (na,pri,loc,pat,!forward_intern_tac l code) + +let add_hints local dbnames0 h = + 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 + | 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 + | HintsDestructEntry (na,pri,loc,pat,code) -> if dbnames0<>[] then warn (str"Database selection not implemented for destruct hints"); Dhyp.add_destructor_hint local na loc pat pri code @@ -601,10 +633,10 @@ let pr_autotactic = | Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c) | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c) | Give_exact c -> (str"exact " ++ pr_lconstr c) - | Res_pf_THEN_trivial_fail (c,clenv) -> + | Res_pf_THEN_trivial_fail (c,clenv) -> (str"apply " ++ pr_lconstr c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) - | Extern tac -> + | Extern tac -> (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) let pr_hint v = @@ -619,17 +651,17 @@ let pr_hints_db (name,db,hintlist) = else (fnl () ++ pr_hint_list hintlist)) (* Print all hints associated to head c in any database *) -let pr_hint_list_for_head c = +let pr_hint_list_for_head c = let dbs = Hintdbmap.to_list !searchtable in - let valid_dbs = - map_succeed - (fun (name,db) -> (name,db,Hint_db.map_all c db)) - dbs + let valid_dbs = + map_succeed + (fun (name,db) -> (name,db,Hint_db.map_all c db)) + dbs in - if valid_dbs = [] then + if valid_dbs = [] then (str "No hint declared for :" ++ pr_global c) - else - hov 0 + else + hov 0 (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ hov 0 (prlist pr_hints_db valid_dbs)) @@ -638,11 +670,11 @@ 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 pr_hint_term cl = + try let dbs = Hintdbmap.to_list !searchtable in - let valid_dbs = - let fn = try + 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 @@ -652,50 +684,53 @@ let pr_hint_term cl = in map_succeed (fun (name, db) -> (name, db, fn db)) dbs in - if valid_dbs = [] then + 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 _ -> + 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 gl = nth_goal_of_pftreestate 1 pts in +let print_applicable_hint () = + let pts = get_pftreestate () in + let gl = nth_goal_of_pftreestate 1 pts 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 msg (hov 0 + ((if Hint_db.use_dn db then str"Discriminated database" + else str"Non-discriminated database") ++ fnl ())); + msg (hov 0 (str"Unfoldable variable definitions: " ++ pr_idpred ids ++ fnl () ++ str"Unfoldable constant definitions: " ++ pr_cpred csts ++ fnl ())); - Hint_db.iter + Hint_db.iter (fun head hintlist -> match head with | Some head -> - msg (hov 0 + msg (hov 0 (str "For " ++ pr_global head ++ str " -> " ++ pr_hint_list hintlist)) | None -> - msg (hov 0 + msg (hov 0 (str "For any goal -> " ++ pr_hint_list hintlist))) db let print_hint_db_by_name dbname = - try + try let db = searchtable_map dbname in print_hint_db db - with Not_found -> + with Not_found -> error_no_such_hint_database dbname - + (* displays all the hints of all databases *) let print_searchtable () = Hintdbmap.iter @@ -714,41 +749,55 @@ let print_searchtable () = let priority l = List.filter (fun (_,hint) -> hint.pri = 0) l -let select_unfold_extern = - List.filter (function (_,{code = (Unfold_nth _ | Extern _)}) -> true | _ -> false) - (* 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; + modulo_conv_on_closed_terms = Some full_transparent_state; use_metas_eagerly = false; modulo_delta = empty_transparent_state; + resolve_evars = true; + use_evars_pattern_unification = false; } (* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve_nodelta (c,clenv) gl = +let h_clenv_refine ev c clenv = + Refiner.abstract_tactic (TacApply (true,ev,[c,NoBindings],None)) + (Clenvtac.clenv_refine ev clenv) + +let unify_resolve_nodelta (c,clenv) gl = let clenv' = connect_clenv gl clenv in - let _ = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in - h_simplest_apply c gl + let clenv'' = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in + h_clenv_refine false c clenv'' gl -let unify_resolve flags (c,clenv) gl = +let unify_resolve flags (c,clenv) gl = let clenv' = connect_clenv gl clenv in - let _ = clenv_unique_resolver false ~flags clenv' gl in - h_apply true false [inj_open c,NoBindings] gl + let clenv'' = clenv_unique_resolver false ~flags clenv' gl in + h_clenv_refine false c clenv'' gl let unify_resolve_gen = function | None -> unify_resolve_nodelta | Some flags -> unify_resolve flags +(* Util *) + +let expand_constructor_hints lems = + list_map_append (fun lem -> + match kind_of_term lem with + | Ind ind -> + list_tabulate (fun i -> mkConstruct (ind,i+1)) (nconstructors ind) + | _ -> + [lem]) lems + (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *) let add_hint_lemmas eapply lems hint_db gl = - let hintlist' = + let lems = expand_constructor_hints 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 @@ -763,21 +812,21 @@ let make_local_hint_db eapply lems gl = terme pour l'affichage ? (HH) *) (* Si on enlève le dernier argument (gl) conclPattern est calculé une -fois pour toutes : en particulier si Pattern.somatch produit une UserError +fois pour toutes : en particulier si Pattern.somatch produit une UserError Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même si après Intros la conclusion matche le pattern. *) (* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) -let forward_interp_tactic = +let forward_interp_tactic = ref (fun _ -> failwith "interp_tactic is not installed for auto") let set_extern_interp f = forward_interp_tactic := f let conclPattern concl pat tac gl = - let constr_bindings = - match pat with + let constr_bindings = + match pat with | None -> [] | Some pat -> try matches pat concl @@ -793,7 +842,7 @@ let conclPattern concl pat tac gl = de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) let flags_of_state st = - {auto_unif_flags with + {auto_unif_flags with modulo_conv_on_closed_terms = Some st; modulo_delta = st} let hintmap_of hdc concl = @@ -802,34 +851,38 @@ let hintmap_of hdc concl = | Some hdc -> if occur_existential concl then Hint_db.map_all hdc else Hint_db.map_auto (hdc,concl) - + +let exists_evaluable_reference env = function + | EvalConstRef _ -> true + | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false + let rec trivial_fail_db mod_delta db_list local_db gl = - let intro_tac = - tclTHEN intro + let intro_tac = + tclTHEN intro (fun g'-> let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') in trivial_fail_db mod_delta db_list (Hint_db.add_list hintl local_db) g') in - tclFIRST + tclFIRST (assumption::intro_tac:: - (List.map tclCOMPLETE + (List.map tclCOMPLETE (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl and my_find_search_nodelta db_list local_db hdc concl = - List.map (fun hint -> (None,hint)) + List.map (fun hint -> (None,hint)) (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 = true} in let f = hintmap_of hdc concl in - if occur_existential concl then + if occur_existential concl then list_map_append - (fun db -> - if Hint_db.use_dn db then + (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 @@ -837,8 +890,8 @@ and my_find_search_delta db_list local_db hdc concl = List.map (fun x -> (Some flags,x)) (f db)) (local_db::db_list) else - list_map_append (fun db -> - if Hint_db.use_dn db then + 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 @@ -859,37 +912,40 @@ and tac_of_hint db_list local_db concl (flags, {pat=p; code=t}) = | Res_pf (term,cl) -> unify_resolve_gen flags (term,cl) | ERes_pf (_,c) -> (fun gl -> error "eres_pf") | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN (unify_resolve_gen flags (term,cl)) (trivial_fail_db (flags <> None) db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] + | Unfold_nth c -> (fun gl -> + if exists_evaluable_reference (pf_env gl) c then + tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl + else tclFAIL 0 (str"Unbound reference") gl) | Extern tacast -> conclPattern concl p tacast - -and trivial_resolve mod_delta db_list local_db cl = - try - let head = + +and trivial_resolve mod_delta db_list local_db cl = + try + let head = try let hdconstr,_ = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None in List.map (tac_of_hint db_list local_db cl) - (priority + (priority (my_find_search mod_delta db_list local_db head cl)) with Not_found -> [] let trivial lems dbnames gl = - let db_list = + let db_list = List.map - (fun x -> - try + (fun x -> + try searchtable_map x - with Not_found -> + with Not_found -> error_no_such_hint_database x) - ("core"::dbnames) + ("core"::dbnames) in - tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl - + tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl + let full_trivial lems gl = let dbnames = Hintdbmap.dom !searchtable in let dbnames = list_subtract dbnames ["v62"] in @@ -903,7 +959,7 @@ let gen_trivial lems = function let inj_open c = (Evd.empty,c) let h_trivial lems l = - Refiner.abstract_tactic (TacTrivial (List.map inj_open lems,l)) + Refiner.abstract_tactic (TacTrivial (lems,l)) (gen_trivial lems l) (**************************************************************************) @@ -911,8 +967,8 @@ let h_trivial lems l = (**************************************************************************) let possible_resolve mod_delta db_list local_db cl = - try - let head = + try + let head = try let hdconstr,_ = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None @@ -931,19 +987,19 @@ let decomp_unary_term_then (id,_,typc) kont1 kont2 gl = kont2 gl with UserError _ -> kont2 gl -let decomp_empty_term (id,_,typc) gl = - if Hipattern.is_empty_type typc then - simplest_case (mkVar id) gl - else +let decomp_empty_term (id,_,typc) gl = + if Hipattern.is_empty_type typc then + simplest_case (mkVar 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 -(* Try to decompose hypothesis [decl] into atomic components of a - conjunction with maximum depth [p] (or solve the goal from an - empty type) then call the continuation tactic with hint db extended - with the obtappined not-further-decomposable hypotheses *) +(* Try to decompose hypothesis [decl] into atomic components of a + conjunction with maximum depth [p] (or solve the goal from an + empty type) then call the continuation tactic with hint db extended + with the obtained not-further-decomposable hypotheses *) let rec decomp_and_register_decl p kont (id,_,_ as decl) db gl = if p = 0 then @@ -962,7 +1018,7 @@ and intros_decomp p kont decls db n = if n = 0 then decomp_and_register_decls p kont decls db else - tclTHEN intro (tclLAST_DECL (fun d -> + tclTHEN intro (onLastDecl (fun d -> (intros_decomp p kont (d::decls) db (n-1)))) (* Decompose hypotheses [hyps] with maximum depth [p] and @@ -973,21 +1029,21 @@ and decomp_and_register_decls p kont decls = List.fold_left (decomp_and_register_decl p) kont decls -(* decomp is an natural number giving an indication on decomposition +(* decomp is an natural number giving an indication on decomposition of conjunction in hypotheses, 0 corresponds to no decomposition *) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) exception Uplift of tactic list -let rec search_gen p n mod_delta db_list local_db = - let rec search n local_db gl = - if n=0 then error "BOUND 2"; - tclFIRST - (assumption :: - intros_decomp p (search n) [] local_db 1 :: - List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db)) - (possible_resolve mod_delta db_list local_db (pf_concl gl))) gl +let search_gen p n mod_delta db_list local_db = + let rec search n local_db = + if n=0 then (fun gl -> error "BOUND 2") else + tclORELSE0 assumption + (tclORELSE0 (intros_decomp p (search n) [] local_db 1) + (fun gl -> tclFIRST + (List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db)) + (possible_resolve mod_delta db_list local_db (pf_concl gl))) gl)) in search n local_db @@ -996,14 +1052,14 @@ let search = search_gen 0 let default_search_depth = ref 5 let delta_auto mod_delta n lems dbnames gl = - let db_list = + let db_list = List.map - (fun x -> - try + (fun x -> + try searchtable_map x - with Not_found -> + with Not_found -> error_no_such_hint_database x) - ("core"::dbnames) + ("core"::dbnames) in tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl @@ -1013,7 +1069,7 @@ let new_auto = delta_auto true let default_auto = auto !default_search_depth [] [] -let delta_full_auto mod_delta n lems gl = +let delta_full_auto mod_delta n lems gl = let dbnames = Hintdbmap.dom !searchtable in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map (fun x -> searchtable_map x) dbnames in @@ -1033,25 +1089,25 @@ let gen_auto n lems dbnames = let inj_or_var = Option.map (fun n -> ArgArg n) let h_auto n lems l = - Refiner.abstract_tactic (TacAuto (inj_or_var n,List.map inj_open lems,l)) + Refiner.abstract_tactic (TacAuto (inj_or_var n,lems,l)) (gen_auto n lems l) (**************************************************************************) (* The "destructing Auto" from Eduardo *) (**************************************************************************) -(* Depth of search after decomposition of hypothesis, by default - one look for an immediate solution *) +(* Depth of search after decomposition of hypothesis, by default + one look for an immediate solution *) let default_search_decomp = ref 20 -let destruct_auto p lems n gl = +let destruct_auto p lems n gl = decomp_and_register_decls p (fun local_db gl -> search_gen p n false (List.map searchtable_map ["core";"extcore"]) (add_hint_lemmas false lems local_db gl) gl) (pf_hyps gl) (Hint_db.empty empty_transparent_state false) gl - + let dautomatic des_opt lems n = tclTRY (destruct_auto des_opt lems n) let dauto (n,p) lems = @@ -1062,7 +1118,7 @@ let dauto (n,p) lems = let default_dauto = dauto (None,None) [] let h_dauto (n,p) lems = - Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,List.map inj_open lems)) + Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,lems)) (dauto (n,p) lems) (***************************************) @@ -1070,41 +1126,37 @@ let h_dauto (n,p) lems = (***************************************) let make_resolve_any_hyp env sigma (id,_,ty) = - let ents = + let ents = map_succeed - (fun f -> f (mkVar id,ty)) - [make_exact_entry None; make_apply_entry env sigma (true,true,false) None] - in + (fun f -> f (mkVar id,ty)) + [make_exact_entry sigma None; make_apply_entry env sigma (true,true,false) None] + in ents type autoArguments = - | UsingTDB - | Destructing - -let keepAfter tac1 tac2 = - (tclTHEN tac1 - (function g -> tac2 [pf_last_hyp g] g)) + | UsingTDB + | Destructing let compileAutoArg contac = function - | Destructing -> - (function g -> - let ctx = pf_hyps g in - tclFIRST - (List.map - (fun (id,_,typ) -> - let cl = snd (decompose_prod typ) in + | Destructing -> + (function g -> + let ctx = pf_hyps g in + tclFIRST + (List.map + (fun (id,_,typ) -> + let cl = (strip_prod_assum typ) in if Hipattern.is_conjunction cl - then - tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac] - else + then + tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac] + else tclFAIL 0 (pr_id id ++ str" is not a conjunction")) ctx) g) - | UsingTDB -> - (tclTHEN - (Tacticals.tryAllClauses - (function - | Some ((_,id),_) -> Dhyp.h_destructHyp false id - | None -> Dhyp.h_destructConcl)) + | UsingTDB -> + (tclTHEN + (Tacticals.tryAllHypsAndConcl + (function + | Some id -> Dhyp.h_destructHyp false id + | None -> Dhyp.h_destructConcl)) contac) let compileAutoArgList contac = List.map (compileAutoArg contac) @@ -1114,20 +1166,20 @@ let rec super_search n db_list local_db argl gl = tclFIRST (assumption :: - tclTHEN intro - (fun g -> + tclTHEN intro + (fun g -> let hintl = pf_apply make_resolve_any_hyp g (pf_last_hyp g) in super_search n db_list (Hint_db.add_list hintl local_db) argl g) :: - List.map (fun ntac -> - tclTHEN ntac + List.map (fun ntac -> + tclTHEN ntac (super_search (n-1) db_list local_db argl)) (possible_resolve false db_list local_db (pf_concl gl)) @ compileAutoArgList (super_search (n-1) db_list local_db argl) argl) gl -let search_superauto n to_add argl g = +let search_superauto n to_add argl g = let sigma = List.fold_right (fun (id,c) -> add_named_decl (id, None, pf_type_of g c)) @@ -1136,14 +1188,12 @@ let search_superauto n to_add argl g = let db = Hint_db.add_list db0 (make_local_hint_db false [] g) in super_search n [Hintdbmap.find "core" !searchtable] db argl g -let superauto n to_add argl = +let superauto n to_add argl = tclTRY (tclCOMPLETE (search_superauto n to_add argl)) -let default_superauto g = superauto !default_search_depth [] [] g - let interp_to_add gl r = - let r = Syntax_def.locate_global_with_alias (qualid_of_reference r) in - let id = id_of_global r in + let r = locate_global_with_alias (qualid_of_reference r) in + let id = basename_of_global r in (next_ident_away id (pf_ids_of_hyps gl), constr_of_global r) let gen_superauto nopt l a b gl = diff --git a/tactics/auto.mli b/tactics/auto.mli index 132b9063..072e0298 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: auto.mli 12187 2009-06-13 19:36:59Z msozeau $ i*) +(*i $Id$ i*) (*i*) open Util @@ -23,26 +23,26 @@ open Libnames open Vernacexpr open Mod_subst (*i*) - -type auto_tactic = + +type auto_tactic = | Res_pf of constr * clausenv (* Hint Apply *) | ERes_pf of constr * clausenv (* Hint EApply *) - | Give_exact of constr + | Give_exact of constr | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) open Rawterm -type pri_auto_tactic = { +type pri_auto_tactic = { pri : int; (* A number between 0 and 4, 4 = lower priority *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) code : auto_tactic; (* the tactic to apply when the concl matches pat *) } -type stored_data = pri_auto_tactic +type stored_data = pri_auto_tactic -type search_entry = stored_data list * stored_data list * stored_data Btermdn.t +type search_entry (* The head may not be bound. *) @@ -63,26 +63,40 @@ module Hint_db : val use_dn : t -> bool val transparent_state : t -> transparent_state val set_transparent_state : t -> transparent_state -> t + + 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 * constr) list + | HintsImmediateEntry of constr list + | 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 + | HintsDestructEntry of identifier * int * (bool,unit) Tacexpr.location * + (patvar list * constr_pattern) * 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]. +(* [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 + [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 current_db_names : unit -> hint_db_name list -val add_hints : locality_flag -> hint_db_name list -> hints -> unit +val interp_hints : hints_expr -> hints_entry + +val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit val print_searchtable : unit -> unit @@ -92,19 +106,21 @@ val print_hint_ref : global_reference -> unit val print_hint_db_by_name : hint_db_name -> unit -(* [make_exact_entry pri (c, ctyp)]. +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 : int option -> constr * constr -> hint_entry +val make_exact_entry : evar_map -> int option -> constr * constr -> hint_entry (* [make_apply_entry (eapply,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 + [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 -> constr * constr -> hint_entry @@ -117,7 +133,7 @@ val make_apply_entry : has missing arguments. *) val make_resolves : - env -> evar_map -> bool * bool * bool -> int option -> constr -> + env -> evar_map -> bool * bool * bool -> int option -> constr -> hint_entry list (* [make_resolve_hyp hname htyp]. @@ -125,7 +141,7 @@ val make_resolves : Never raises a user exception; If the hyp cannot be used as a Hint, the empty list is returned. *) -val make_resolve_hyp : +val make_resolve_hyp : env -> evar_map -> named_declaration -> hint_entry list (* [make_extern pri pattern tactic_expr] *) @@ -163,7 +179,7 @@ val unify_resolve_nodelta : (constr * clausenv) -> tactic val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic (* [ConclPattern concl pat tacast]: - if the term concl matches the pattern pat, (in sense of + 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 *) @@ -187,7 +203,7 @@ val full_auto : int -> constr list -> tactic and doing delta *) val new_full_auto : int -> constr list -> tactic -(* auto with default search depth and with all hint databases +(* auto with default search depth and with all hint databases except the "v62" compatibility database *) val default_full_auto : tactic @@ -216,8 +232,8 @@ val h_dauto : int option * int option -> constr list -> tactic (* SuperAuto *) type autoArguments = - | UsingTDB - | Destructing + | UsingTDB + | Destructing (* val superauto : int -> (identifier * constr) list -> autoArguments list -> tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 4759b6da..b0645744 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: autorewrite.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id$ *) open Equality open Hipattern @@ -25,83 +25,119 @@ open Tacexpr open Mod_subst (* Rewriting rules *) -(* the type is the statement of the lemma constr. Used to elim duplicates. *) -type rew_rule = constr * types * bool * glob_tactic_expr +type rew_rule = { rew_lemma: constr; + rew_type: types; + rew_pat: constr; + rew_l2r: bool; + rew_tac: glob_tactic_expr } + +let subst_hint subst hint = + let cst' = subst_mps subst hint.rew_lemma in + let typ' = subst_mps subst hint.rew_type in + let pat' = subst_mps subst hint.rew_pat in + let t' = Tacinterp.subst_tactic subst hint.rew_tac in + if hint.rew_lemma == cst' && hint.rew_tac == t' then hint else + { hint with + rew_lemma = cst'; rew_type = typ'; + rew_pat = pat'; rew_tac = t' } + +module HintIdent = +struct + type t = int * rew_rule + + let compare (i,t) (i',t') = + Pervasives.compare i i' +(* Pervasives.compare t.rew_lemma t'.rew_lemma *) + + let subst s (i,t) = (i,subst_hint s t) + + let constr_of (i,t) = t.rew_pat +end + +module HintOpt = +struct + let reduce c = c + let direction = true +end + +module HintDN = Term_dnet.Make(HintIdent)(HintOpt) (* Summary and Object declaration *) let rewtab = - ref (Stringmap.empty : rew_rule list Stringmap.t) + ref (Stringmap.empty : HintDN.t Stringmap.t) -let _ = +let _ = let init () = rewtab := Stringmap.empty in let freeze () = !rewtab in let unfreeze fs = rewtab := fs in Summary.declare_summary "autorewrite" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; - Summary.init_function = init; - Summary.survive_module = false; - Summary.survive_section = false } + Summary.init_function = init } -let print_rewrite_hintdb bas = - try - let hints = Stringmap.find bas !rewtab in - ppnl (str "Database " ++ str bas ++ (Pp.cut ()) ++ - prlist_with_sep Pp.cut - (fun (c,typ,d,t) -> - str (if d then "rewrite -> " else "rewrite <- ") ++ - Printer.pr_lconstr c ++ str " of type " ++ Printer.pr_lconstr typ ++ - str " then use tactic " ++ - Pptactic.pr_glob_tactic (Global.env()) t) hints) +let find_base bas = + try Stringmap.find bas !rewtab with - Not_found -> - errorlabstrm "AutoRewrite" + Not_found -> + errorlabstrm "AutoRewrite" (str ("Rewriting base "^(bas)^" does not exist.")) -type raw_rew_rule = constr * bool * raw_tactic_expr +let find_rewrites bas = + List.rev_map snd (HintDN.find_all (find_base 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 + +let print_rewrite_hintdb bas = + ppnl (str "Database " ++ str bas ++ (Pp.cut ()) ++ + prlist_with_sep Pp.cut + (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) + (find_rewrites bas)) + +type raw_rew_rule = loc * constr * bool * raw_tactic_expr (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = - let lrul = - try - Stringmap.find bas !rewtab - with Not_found -> - errorlabstrm "AutoRewrite" - (str ("Rewriting base "^(bas)^" does not exist.")) - in - let lrul = List.map (fun (c,_,b,t) -> (c,b,Tacinterp.eval_tactic t)) lrul in + 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 - (tclTHENSFIRSTn (general_rewrite_maybe_in dir csr) [|tac_main|] tc))) + (tclREPEAT_MAIN + (tclTHENFIRST (general_rewrite_maybe_in dir csr tc) tac_main))) tclIDTAC lrul)) - - (* The AutoRewrite tactic *) -let autorewrite tac_main lbas = +let autorewrite ?(conds=Naive) tac_main lbas = tclREPEAT_MAIN (tclPROGRESS - (List.fold_left (fun tac bas -> + (List.fold_left (fun tac bas -> tclTHEN tac - (one_base (fun dir -> general_rewrite dir all_occurrences) + (one_base (fun dir c tac -> + let tac = tac, conds in + general_rewrite dir all_occurrences false ~tac c) tac_main bas)) tclIDTAC lbas)) -let autorewrite_multi_in idl tac_main lbas : tactic = - fun gl -> +let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic = + 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 general_rewrite_in id = let id = ref id in let to_be_cleared = ref false in - fun dir cstr gl -> + fun dir cstr tac gl -> let last_hyp_id = match (Environ.named_context_of_val gl.Evd.it.Evd.evar_hyps) with (last_hyp_id,_,_)::_ -> last_hyp_id | _ -> (* even the hypothesis id is missing *) error ("No such hypothesis: " ^ (string_of_id !id) ^".") in - let gl' = general_rewrite_in dir all_occurrences !id cstr false gl in + let gl' = general_rewrite_in dir all_occurrences ~tac:(tac, conds) false !id cstr false gl in let gls = (fst gl').Evd.it in match gls with g::_ -> @@ -125,109 +161,152 @@ let autorewrite_multi_in 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 -> + tclMAP (fun id -> tclREPEAT_MAIN (tclPROGRESS - (List.fold_left (fun tac bas -> + (List.fold_left (fun tac bas -> tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) tclIDTAC lbas))) idl gl -let autorewrite_in id = autorewrite_multi_in [id] +let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] -let gen_auto_multi_rewrite tac_main lbas cl = - let try_do_hyps treat_id l = - autorewrite_multi_in (List.map treat_id l) tac_main lbas - in +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 - then + then error "The \"at\" syntax isn't available yet for the autorewrite tactic." - else - let compose_tac t1 t2 = - match cl.onhyps with - | Some [] -> t1 + else + let compose_tac t1 t2 = + match cl.onhyps with + | Some [] -> t1 | _ -> tclTHENFIRST t1 t2 in compose_tac - (if cl.concl_occs <> no_occurrences_expr then autorewrite tac_main lbas else tclIDTAC) - (match cl.onhyps with + (if cl.concl_occs <> no_occurrences_expr then autorewrite ~conds tac_main lbas else tclIDTAC) + (match cl.onhyps with | Some l -> try_do_hyps (fun ((_,id),_) -> id) l - | None -> - fun gl -> - (* try to rewrite in all hypothesis + | 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) -let auto_multi_rewrite = gen_auto_multi_rewrite Refiner.tclIDTAC +let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds Refiner.tclIDTAC -let auto_multi_rewrite_with tac_main lbas cl gl = +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 - | 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 + match onconcl,cl.Tacexpr.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 tac_main lbas cl gl - | _ -> - Util.errorlabstrm "autorewrite" + gen_auto_multi_rewrite conds tac_main lbas cl gl + | _ -> + Util.errorlabstrm "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 l = - try - let oldl = Stringmap.find rbase !rewtab in - let lrl = - List.map - (fun (c,dummy,b,t) -> - (* here we substitute the dummy value with the right one *) - c,Typing.type_of (Global.env ()) Evd.empty c,b,t) lrl in - (List.filter - (fun (_,typ,_,_) -> - not (List.exists (fun (_,typ',_,_) -> Term.eq_constr typ typ') oldl) - ) lrl) @ oldl - with - | Not_found -> lrl - in - rewtab:=Stringmap.add rbase l !rewtab - -let export_hintrewrite x = Some x - -let subst_hintrewrite (_,subst,(rbase,list as node)) = - let subst_first (cst,typ,b,t as pair) = - let cst' = subst_mps subst cst in - let typ' = - (* here we do not have the environment and Global.env () is not the - one where cst' lives in. Thus we can just put a dummy value and - override it in cache_hintrewrite *) - typ (* dummy value, it will be recomputed by cache_hintrewrite *) in - let t' = Tacinterp.subst_tactic subst t in - if cst == cst' && t == t' then pair else - (cst',typ',b,t') - in - let list' = list_smartmap subst_first list in + let base = try find_base rbase with _ -> HintDN.empty in + let max = try fst (Util.list_last (HintDN.find_all base)) with _ -> 0 in + let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in + rewtab:=Stringmap.add rbase (HintDN.union lrl base) !rewtab + + +let subst_hintrewrite (subst,(rbase,list as node)) = + let list' = HintDN.subst subst list in if list' == list then node else (rbase,list') - -let classify_hintrewrite (_,x) = Libobject.Substitute x + +let classify_hintrewrite x = Libobject.Substitute x (* Declaration of the Hint Rewrite library object *) -let (inHintRewrite,outHintRewrite)= +let (inHintRewrite,_)= Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with - Libobject.cache_function = cache_hintrewrite; - Libobject.load_function = (fun _ -> cache_hintrewrite); - Libobject.subst_function = subst_hintrewrite; - Libobject.classify_function = classify_hintrewrite; - Libobject.export_function = export_hintrewrite } + Libobject.cache_function = cache_hintrewrite; + Libobject.load_function = (fun _ -> cache_hintrewrite); + Libobject.subst_function = subst_hintrewrite; + Libobject.classify_function = classify_hintrewrite } + + +open Clenv + +type hypinfo = { + hyp_cl : clausenv; + hyp_prf : constr; + hyp_ty : types; + hyp_car : constr; + hyp_rel : constr; + hyp_l2r : bool; + hyp_left : constr; + hyp_right : constr; +} + +let evd_convertible env evd x y = + try + ignore(Unification.w_unify true env Reduction.CONV x y evd); true + (* try ignore(Evarconv.the_conv_x env x y evd); true *) + with _ -> 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 + let eqclause = + if metas then eqclause + else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) + 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 + | _ -> raise Not_found + in + try + let others,(c1,c2) = split_last_two args in + let ty1, ty2 = + Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2 + in +(* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) +(* else *) + Some { hyp_cl=eqclause; hyp_prf=(Clenv.clenv_value eqclause); hyp_ty = ty; + hyp_car=ty1; hyp_rel=mkApp (equiv, Array.of_list others); + hyp_l2r=left2right; hyp_left=c1; hyp_right=c2; } + with Not_found -> None + in + match find_rel ctype with + | Some c -> Some c + | None -> + let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' ctx) with + | Some c -> Some c + | None -> None + +let find_applied_relation metas loc env sigma c left2right = + let ctype = Typing.type_of env sigma c in + match decompose_applied_relation metas env sigma c ctype left2right with + | Some c -> c + | None -> + user_err_loc (loc, "decompose_applied_relation", + str"The type" ++ spc () ++ Printer.pr_constr_env env ctype ++ + spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) let add_rew_rules base lrul = + let counter = ref 0 in let lrul = - List.rev_map - (fun (c,b,t) -> - (c,mkProp (* dummy value *), b,Tacinterp.glob_tactic t) - ) lrul - in - Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) + List.fold_left + (fun dn (loc,c,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} + 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 f402a35d..cf0d58cc 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -6,25 +6,60 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: autorewrite.mli 9073 2006-08-22 08:54:29Z jforest $ i*) +(*i $Id$ i*) (*i*) +open Term +open Tacexpr open Tacmach +open Equality (*i*) (* Rewriting rules before tactic interpretation *) -type raw_rew_rule = Term.constr * bool * Tacexpr.raw_tactic_expr +type raw_rew_rule = Util.loc * Term.constr * bool * Tacexpr.raw_tactic_expr (* To add rewriting rules to a base *) val add_rew_rules : string -> raw_rew_rule list -> unit -(* The AutoRewrite tactic *) -val autorewrite : tactic -> string list -> tactic -val autorewrite_in : Names.identifier -> tactic -> string list -> tactic +(* The AutoRewrite tactic. + The optional conditions tell rewrite how to handle matching and side-condition solving. + Default is Naive: first match in the clause, don't look at the side-conditions to + tell if the rewrite succeeded. *) +val autorewrite : ?conds:conditions -> tactic -> string list -> tactic +val autorewrite_in : ?conds:conditions -> Names.identifier -> tactic -> string list -> tactic +(* Rewriting rules *) +type rew_rule = { rew_lemma: constr; + rew_type: types; + rew_pat: constr; + rew_l2r: bool; + rew_tac: glob_tactic_expr } -val auto_multi_rewrite : string list -> Tacticals.clause -> tactic +val find_rewrites : string -> rew_rule list -val auto_multi_rewrite_with : tactic -> string list -> Tacticals.clause -> tactic +val find_matches : string -> constr -> rew_rule list + +val auto_multi_rewrite : ?conds:conditions -> string list -> Tacticals.clause -> tactic + +val auto_multi_rewrite_with : ?conds:conditions -> tactic -> string list -> Tacticals.clause -> tactic val print_rewrite_hintdb : string -> unit + +open Clenv + + +type hypinfo = { + hyp_cl : clausenv; + hyp_prf : constr; + hyp_ty : types; + hyp_car : constr; + hyp_rel : constr; + hyp_l2r : bool; + hyp_left : constr; + hyp_right : constr; +} + +val find_applied_relation : bool -> + Util.loc -> + Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo + diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index a0aecbbc..bcb9a411 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: btermdn.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id$ *) open Term open Names @@ -19,72 +19,135 @@ open Libnames Eduardo (5/8/97). *) let dnet_depth = ref 8 - -let bounded_constr_pat_discr_st st (t,depth) = - if 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 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 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 -type 'a t = (global_reference,constr_pattern * int,'a) Dn.t - -let create = Dn.create +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) + end + + module Dn = Dn.Make(X)(Y)(Z) -let add = function - | None -> - (fun dn (c,v) -> - Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> - Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + type t = Dn.t -let rmv = function - | None -> - (fun dn (c,v) -> - Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> - Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + let create = Dn.create -let lookup = function - | None -> - (fun dn t -> - List.map - (fun ((c,_),v) -> (c,v)) - (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 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 app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn + 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 s when is_small s -> Dn.Label(Term_dn.SortLabel (Some s), []) + | Sort _ -> Dn.Label(Term_dn.SortLabel None, []) + | 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) -> + Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),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) -> + Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) + | Some st -> + (fun dn (c,v) -> + Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + + let lookup = function + | None -> + (fun dn t -> + List.map + (fun ((c,_),v) -> (c,v)) + (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 + +end + diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index 959f7d10..ebded23a 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: btermdn.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id$ i*) (*i*) open Term @@ -15,15 +15,19 @@ open Names (*i*) (* Discrimination nets with bounded depth. *) +module Make : + functor (Z : Map.OrderedType) -> +sig + type t -type 'a t + val create : unit -> t -val create : unit -> 'a t - -val add : transparent_state option -> 'a t -> (constr_pattern * 'a) -> 'a t -val rmv : transparent_state option -> 'a t -> (constr_pattern * 'a) -> 'a t - -val lookup : transparent_state option -> 'a t -> constr -> (constr_pattern * 'a) list -val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit + 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 +end + val dnet_depth : int ref + diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index b7eb3620..55558764 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -9,7 +9,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: class_tactics.ml4 12189 2009-06-15 05:08:44Z msozeau $ *) +(* $Id$ *) open Pp open Util @@ -43,21 +43,50 @@ open Evd let default_eauto_depth = 100 let typeclasses_db = "typeclass_instances" -let _ = Auto.auto_init := (fun () -> +let _ = Auto.auto_init := (fun () -> Auto.create_hint_db false typeclasses_db full_transparent_state true) -let check_required_library d = - let d' = List.map id_of_string d in - let dir = make_dirpath (List.rev d') in - if not (Library.library_is_loaded dir) then - error ("Library "^(list_last d)^" has to be required first.") +exception Found of evar_map + +let is_dependent ev evm = + Evd.fold (fun ev' evi dep -> + if ev = ev' then dep + else dep || occur_evar ev evi.evar_concl) + evm false + +let valid goals p res_sigma l = + let evm = + List.fold_left2 + (fun sigma (ev, evi) prf -> + let cstr, obls = Refiner.extract_open_proof !res_sigma prf in + if not (Evd.is_defined sigma ev) then + Evd.define ev cstr sigma + else sigma) + !res_sigma goals l + in raise (Found evm) + +let evar_filter evi = + let hyps' = evar_filtered_context evi in + { evi with + evar_hyps = Environ.val_of_named_context hyps'; + evar_filter = List.map (fun _ -> true) hyps' } -let classes_dirpath = - make_dirpath (List.map id_of_string ["Classes";"Coq"]) - -let init_setoid () = - if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () - else check_required_library ["Coq";"Setoids";"Setoid"] +let evars_to_goals p evm = + let goals, evm' = + Evd.fold + (fun ev evi (gls, evm') -> + if evi.evar_body = Evar_empty then + let evi', goal = p evm ev evi in + if goal then + ((ev, evi') :: gls, Evd.add evm' ev evi') + else (gls, Evd.add evm' ev evi') + else (gls, Evd.add evm' ev evi)) + evm ([], Evd.empty) + in + if goals = [] then None + else + let goals = List.rev goals in + Some (goals, evm') (** Typeclasses instance search tactic / eauto *) @@ -67,13 +96,9 @@ let intersects s t = open Auto let e_give_exact flags c gl = - let t1 = (pf_type_of gl c) and t2 = pf_concl gl in - if occur_existential t1 or occur_existential t2 then - tclTHEN (Clenvtac.unify (* ~flags *) t1) (exact_no_check c) gl - else exact_check c gl -(* let t1 = (pf_type_of gl c) in *) -(* tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl *) - + let t1 = (pf_type_of gl c) in + tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl + let assumption flags id = e_give_exact flags (mkVar id) open Unification @@ -82,95 +107,116 @@ let auto_unif_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; use_metas_eagerly = true; modulo_delta = var_full_transparent_state; + resolve_evars = false; + use_evars_pattern_unification = true; } -let unify_e_resolve flags (c,clenv) gls = +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 (snd t) ] +END + +let unify_e_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in - let clenv' = clenv_unique_resolver false ~flags clenv' gls - in - Clenvtac.clenv_refine true ~with_classes:false clenv' gls - -let unify_resolve flags (c,clenv) gls = + let clenv' = clenv_unique_resolver false ~flags clenv' gls in + tclPROGRESS (Clenvtac.clenv_refine true ~with_classes:false clenv') gls + +let unify_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in - let clenv' = clenv_unique_resolver false ~flags clenv' gls - in - Clenvtac.clenv_refine false ~with_classes:false clenv' gls + let clenv' = clenv_unique_resolver false ~flags clenv' gls in + tclPROGRESS (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 + {auto_unif_flags with modulo_conv_on_closed_terms = Some st; modulo_delta = st} let rec e_trivial_fail_db db_list local_db goal = - let tacl = + let tacl = Eauto.registered_e_assumption :: - (tclTHEN Tactics.intro + (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 pi1 (e_trivial_resolve db_list local_db (pf_concl goal)) ) + (List.map (fun (x,_,_,_) -> x) (e_trivial_resolve db_list local_db (pf_concl goal))) in tclFIRST (List.map tclCOMPLETE tacl) goal -and e_my_find_search db_list local_db hdc concl = +and e_my_find_search db_list local_db hdc 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 + (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}) -> + in + let tac_of_hint = + fun (flags, {pri=b; pat = p; code=t}) -> let tac = match t with - | Res_pf (term,cl) -> unify_resolve flags (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve flags (term,cl) + | 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 (unify_e_resolve flags (term,cl)) + tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags)) (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] + | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [all_occurrences,c]) | Extern tacast -> conclPattern concl p tacast - in - (tac,b,pr_autotactic t) - in - List.map tac_of_hint hintl + in + match t with + | Extern _ -> (tac,b,true,lazy (pr_autotactic t)) + | _ -> (tac,b,false,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 +and e_trivial_resolve db_list local_db gl = + try + e_my_find_search db_list local_db (fst (head_constr_bound gl)) gl with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = - try - e_my_find_search db_list local_db + try + e_my_find_search db_list local_db (fst (head_constr_bound gl)) gl with Bound | Not_found -> [] -let find_first_goal gls = - try first_goal gls with UserError _ -> assert false - -type search_state = { - depth : int; (*r depth of search before failing *) - tacres : goal list sigma * validation; - pri : int; - last_tactic : std_ppcmds; - dblist : Auto.hint_db list; - localdb : (bool ref * bool ref option * Auto.hint_db) list } - -let filter_hyp t = - match kind_of_term t with - | Evar _ | Meta _ | Sort _ -> false - | _ -> true - let rec catchable = function | Refiner.FailError _ -> true | Stdpp.Exc_located (_, e) -> catchable e @@ -181,275 +227,339 @@ let is_dep gl gls = if evs = Intset.empty then false else List.fold_left - (fun b gl -> - if b then b + (fun b gl -> + if b then b else let evs' = Evarutil.evars_of_term gl.evar_concl in intersects evs evs') false gls -module SearchProblem = struct - - type state = search_state - - let debug = ref false - - let success s = sig_it (fst s.tacres) = [] - - let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) - - let pr_goals gls = - let evars = Evarutil.nf_evars (Refiner.project gls) in - prlist (pr_ev evars) (sig_it gls) - - let filter_tactics (glls,v) l = - let glls,nv = apply_tac_list Refiner.tclNORMEVAR glls in - let v p = v (nv p) in - let rec aux = function - | [] -> [] - | (tac,pri,pptac) :: tacl -> - try - let (lgls,ptl) = apply_tac_list tac glls in - let v' p = v (ptl p) in - ((lgls,v'),pri,pptac) :: aux tacl - with e when catchable e -> aux tacl - in aux l - - let nb_empty_evars s = - Evd.fold (fun ev evi acc -> if evi.evar_body = Evar_empty then succ acc else acc) s 0 - - (* Ordering of states is lexicographic on depth (greatest first) then - priority (lowest pri means higher priority), then number of remaining goals. *) - let compare s s' = - let d = s'.depth - s.depth in - let nbgoals s = - List.length (sig_it (fst s.tacres)) + - nb_empty_evars (sig_sig (fst s.tacres)) - in - if d <> 0 then d else - let pri = s.pri - s'.pri in - if pri <> 0 then pri - else nbgoals s - nbgoals s' - - let branching s = - if s.depth = 0 then - [] - else - let (cut, do_cut, ldb as hdldb) = List.hd s.localdb in - if !cut then -(* let {it=gls; sigma=sigma} = fst s.tacres in *) -(* msg (str"cut:" ++ pr_ev sigma (List.hd gls) ++ str"\n"); *) - [] - else begin - let {it=gl; sigma=sigma} = fst s.tacres in - Option.iter (fun r -> -(* msg (str"do cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *) - r := true) do_cut; - let gl = List.map (Evarutil.nf_evar_info sigma) gl in - let nbgl = List.length gl in -(* let gl' = { it = gl ; sigma = sigma } in *) -(* let tacres' = gl', snd s.tacres in *) - let new_db, localdb = - let tl = List.tl s.localdb in - match tl with - | [] -> hdldb, tl - | (cut', do', ldb') :: rest -> - if not (is_dep (List.hd gl) (List.tl gl)) then - let fresh = ref false in - if do' = None then ( -(* msg (str"adding a cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *) - (fresh, None, ldb), (cut', Some fresh, ldb') :: rest - ) else ( -(* msg (str"keeping the previous cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *) - (cut', None, ldb), tl ) - else hdldb, tl - in let localdb = new_db :: localdb in - let intro_tac = - List.map - (fun ((lgls,_) as res,pri,pp) -> - let g' = first_goal lgls in - let hintl = - make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in - let ldb = Hint_db.add_list hintl ldb in - { s with tacres = res; - last_tactic = pp; - pri = pri; - localdb = (cut, None, ldb) :: List.tl s.localdb }) - (filter_tactics s.tacres [Tactics.intro,1,(str "intro")]) - in - let possible_resolve ((lgls,_) as res, pri, pp) = - let nbgl' = List.length (sig_it lgls) in - if nbgl' < nbgl then - { s with - depth = pred s.depth; - tacres = res; last_tactic = pp; pri = pri; - localdb = List.tl localdb } - else - { s with depth = pred s.depth; tacres = res; - last_tactic = pp; pri = pri; - localdb = list_tabulate (fun _ -> new_db) (nbgl'-nbgl) @ localdb } - in - let rec_tacs = - let l = - filter_tactics s.tacres (e_possible_resolve s.dblist ldb (List.hd gl).evar_concl) - in - List.map possible_resolve l - in - List.sort compare (intro_tac @ rec_tacs) - end - - let pp s = - msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ - s.last_tactic ++ str "\n")) - -end - -module Search = Explore.Make(SearchProblem) - -let make_initial_state n gls dblist localdbs = - { depth = n; - tacres = gls; - pri = 0; - last_tactic = (mt ()); - dblist = dblist; - localdb = localdbs } - -let e_depth_search debug s = - let tac = if debug then - (SearchProblem.debug := true; Search.debug_depth_first) else Search.depth_first in - let s = tac s in - s.tacres - -let e_breadth_search debug s = - try - let tac = - if debug then Search.debug_breadth_first else Search.breadth_first - in let s = tac s in s.tacres - with Not_found -> error "eauto: breadth first search failed." +let is_ground gl = + Evarutil.is_ground_term (project gl) (pf_concl gl) + +let nb_empty_evars s = + Evd.fold (fun ev evi acc -> if evi.evar_body = Evar_empty then succ acc else acc) s 0 + +let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) + +let typeclasses_debug = ref false +type validation = evar_map -> proof_tree list -> proof_tree -(* A special one for getting everything into a dnet. *) +let pr_depth l = prlist_with_sep (fun () -> str ".") pr_int (List.rev l) -let is_transparent_gr (ids, csts) = function - | VarRef id -> Idpred.mem id ids - | ConstRef cst -> Cpred.mem cst csts - | IndRef _ | ConstructRef _ -> false +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} +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 } -let make_resolve_hyp env sigma st flags pri (id, _, cty) = +type auto_result = autogoal list sigma * validation + +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 ctx, ar = decompose_prod cty in - let keep = - match kind_of_term (fst (decompose_app ar)) with - | Const c -> is_class (ConstRef c) - | Ind i -> is_class (IndRef i) - | _ -> false + 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 keep = not only_classes || iscl env cty in if keep then let c = mkVar id in map_succeed - (fun f -> f (c,cty)) - [make_exact_entry pri; make_apply_entry env sigma flags pri] + (fun f -> try f (c,cty) with UserError _ -> failwith "") + [make_exact_entry sigma pri; make_apply_entry env sigma flags pri] else [] -let make_local_hint_db st eapply lems g = - let sign = pf_hyps g in - let hintlist = list_map_append (pf_apply make_resolve_hyp g st (eapply,false,false) None) sign in - let hintlist' = list_map_append (pf_apply make_resolves g (eapply,false,false) None) lems in - Hint_db.add_list hintlist' (Hint_db.add_list hintlist (Hint_db.empty st true)) - -let e_search_auto debug (in_depth,p) lems st db_list gls = - let sigma = Evd.sig_sig (fst gls) and gls' = Evd.sig_it (fst gls) in - let local_dbs = List.map (fun gl -> - let db = make_local_hint_db st true lems ({it = gl; sigma = sigma}) in - (ref false, None, db)) gls' in - let state = make_initial_state p gls db_list local_dbs in - if in_depth then - e_depth_search debug state - else - e_breadth_search debug state - -let full_eauto debug n lems gls = - let dbnames = current_db_names () in - let dbnames = list_subtract dbnames ["v62"] in - let db_list = List.map searchtable_map dbnames in - let db = searchtable_map typeclasses_db in - e_search_auto debug n lems (Hint_db.transparent_state db) db_list gls +let pf_filtered_hyps gls = + evar_filtered_context (sig_it gls) -let nf_goal (gl, valid) = - { gl with sigma = Evarutil.nf_evars gl.sigma }, valid +let make_autogoal_hints only_classes ?(st=full_transparent_state) g = + let sign = pf_filtered_hyps g in + let hintlist = list_map_append (pf_apply make_resolve_hyp g st (true,false,false) only_classes None) sign in + Hint_db.add_list hintlist (Hint_db.empty st true) + +let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = + { skft = fun sk fk {it = gl,hints; sigma=s} -> + let res = try Some (tac {it=gl; sigma=s}) with e when catchable e -> None in + match res with + | Some (gls,v) -> sk (f gls hints, fun _ -> v) fk + | None -> fk () } + +let intro_tac : atac = + lift_tactic Tactics.intro + (fun {it = gls; sigma = s} info -> + let gls' = + List.map (fun g' -> + let env = evar_env g' in + let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) + (true,false,false) info.only_classes None (List.hd (evar_context g')) in + let ldb = Hint_db.add_list hint info.hints in + (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls + in {it = gls'; sigma = s}) + +let normevars_tac : atac = + lift_tactic tclNORMEVAR + (fun {it = gls; sigma = s} info -> + let gls' = + List.map (fun g' -> + (g', { info with auto_last_tac = lazy (str"NORMEVAR") })) gls + in {it = gls'; sigma = s}) + + +let id_tac : atac = + { skft = fun sk fk {it = gl; sigma = s} -> + sk ({it = [gl]; sigma = s}, fun _ pfs -> List.hd pfs) fk } + +(* 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 typeclasses_eauto debug n lems gls = - let db = searchtable_map typeclasses_db in - e_search_auto debug n lems (Hint_db.transparent_state db) [db] gls +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 } -exception Found of evar_map +let solve_tac (x : 'a tac) : 'a tac = + { skft = fun sk fk gls -> x.skft (fun ({it = gls},_ as res) fk -> if gls = [] then sk res fk else fk ()) fk gls } -let valid goals p res_sigma l = - let evm = - List.fold_left2 - (fun sigma (ev, evi) prf -> - let cstr, obls = Refiner.extract_open_proof !res_sigma prf in - if not (Evd.is_defined sigma ev) then - Evd.define sigma ev cstr - else sigma) - !res_sigma goals l - in raise (Found evm) +let hints_tac hints = + { skft = fun sk fk {it = gl,info; sigma = s} -> + let possible_resolve ((lgls,v) as res, pri, b, pp) = + (pri, pp, b, res) + in + let tacs = + let concl = gl.evar_concl in + let poss = e_possible_resolve hints info.hints concl in + let l = + let tacgl = {it = gl; sigma = s} in + Util.list_map_append (fun (tac, pri, b, pptac) -> + try [tac tacgl, pri, b, pptac] with e when catchable e -> []) + poss + in + if l = [] && !typeclasses_debug then + msgnl (pr_depth info.auto_depth ++ str": no match for " ++ + Printer.pr_constr_env (Evd.evar_env gl) concl ++ + spc () ++ int (List.length poss) ++ str" possibilities"); + List.map possible_resolve l + in + let tacs = List.sort compare tacs in + let rec aux i = function + | (_, pp, b, ({it = gls; sigma = s}, v)) :: tl -> + if !typeclasses_debug then msgnl (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp + ++ str" on" ++ spc () ++ pr_ev s gl); + let fk = + (fun () -> (* if !typeclasses_debug then msgnl (str"backtracked after " ++ pp); *) + aux (succ i) tl) + in + let sgls = evars_to_goals (fun evm ev evi -> + if Typeclasses.is_resolvable evi && + (not info.only_classes || Typeclasses.is_class_evar evm evi) then + Typeclasses.mark_unresolvable evi, true + else evi, false) s + in + let nbgls, newgls, s' = + let gls' = List.map (fun g -> (None, g)) gls in + match sgls with + | None -> List.length gls', gls', s + | Some (evgls, s') -> + (List.length gls', gls' @ List.map (fun (ev, x) -> (Some ev, x)) evgls, s') + in + let gls' = list_map_i (fun j (evar, g) -> + let info = + { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp; + is_evar = evar; + hints = + if b && g.evar_hyps <> gl.evar_hyps + then make_autogoal_hints info.only_classes + ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s'} + else info.hints } + in g, info) 1 newgls in + let glsv = {it = gls'; sigma = s'}, (fun _ pfl -> v (list_firstn nbgls pfl)) in + sk glsv fk + | [] -> fk () + in aux 1 tacs } + +let evars_of_term c = + let rec evrec acc c = + match kind_of_term c with + | Evar (n, _) -> Intset.add n acc + | _ -> fold_constr evrec acc c + in evrec Intset.empty c -let is_dependent ev evm = - Evd.fold (fun ev' evi dep -> - if ev = ev' then dep - else dep || occur_evar ev evi.evar_concl) - evm false - -let resolve_all_evars_once debug (mode, depth) env p evd = - let evm = Evd.evars_of evd in - let goals, evm' = - Evd.fold - (fun ev evi (gls, evm') -> - if evi.evar_body = Evar_empty - && Typeclasses.is_resolvable evi -(* && not (is_dependent ev evm) *) - && p ev evi then ((ev,evi) :: gls, Evd.add evm' ev (Typeclasses.mark_unresolvable evi)) else - (gls, Evd.add evm' ev evi)) - evm ([], Evd.empty) - in - let goals = List.rev goals in - let gls = { it = List.map snd goals; sigma = evm' } in - let res_sigma = ref evm' in - let gls', valid' = typeclasses_eauto debug (mode, depth) [] (gls, valid goals p res_sigma) in - res_sigma := Evarutil.nf_evars (sig_sig gls'); - try ignore(valid' []); assert(false) - with Found evm' -> Evarutil.nf_evar_defs (Evd.evars_reset_evd evm' evd) +exception Found_evar of int + +let occur_evars evars c = + try + let rec evrec c = + match kind_of_term c with + | Evar (n, _) -> if Intset.mem n evars then raise (Found_evar n) else () + | _ -> iter_constr evrec c + in evrec c; false + with Found_evar _ -> true + +let dependent only_classes evd oev concl = + let concl_evars = Intset.union (evars_of_term concl) + (Option.cata Intset.singleton Intset.empty oev) + in not (Intset.is_empty concl_evars) + +let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = + let rec aux s (acc : (autogoal list * validation) list) fk = function + | (gl,info) :: gls -> + second.skft (fun ({it=gls';sigma=s'},v') fk' -> + let s', needs_backtrack = + if gls' = [] then + match info.is_evar with + | Some ev -> + let s' = + if Evd.is_defined s' ev then s' + else + let prf = v' s' [] in + let term, _ = Refiner.extract_open_proof s' prf in + Evd.define ev term s' + in s', dependent info.only_classes s' (Some ev) gl.evar_concl + | None -> s', dependent info.only_classes s' None gl.evar_concl + else s', true + in + let fk'' = if not needs_backtrack then + (if !typeclasses_debug then msgnl (str"no backtrack on " ++ pr_ev s gl); fk) else fk' + in aux s' ((gls',v')::acc) fk'' gls) + fk {it = (gl,info); sigma = s} + | [] -> Some (List.rev acc, s, fk) + in fun ({it = gls; sigma = s},v) fk -> + let rec aux' = function + | None -> fk () + | Some (res, s', fk') -> + let goals' = List.concat (List.map (fun (gls,v) -> gls) res) in + let v' s' pfs' : proof_tree = + let (newpfs, rest) = List.fold_left (fun (newpfs,pfs') (gls,v) -> + let before, after = list_split_at (List.length gls) pfs' in + (v s' before :: newpfs, after)) + ([], pfs') res + in assert(rest = []); v s' (List.rev newpfs) + in sk ({it = goals'; sigma = s'}, v') (fun () -> aux' (fk' ())) + 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 s pfs -> valid goals p (ref s) pfs) + (fun _ -> None) + +let rec fix (t : 'a tac) : 'a tac = + then_tac t { skft = fun sk fk -> (fix t).skft sk fk } + +let make_autogoal ?(only_classes=true) ?(st=full_transparent_state) ev g = + let hints = make_autogoal_hints only_classes ~st g in + (g.it, { hints = hints ; is_evar = ev; + only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (mt()) }) + +let make_autogoals ?(only_classes=true) ?(st=full_transparent_state) gs evm' = + { it = list_map_i (fun i g -> + let (gl, auto) = make_autogoal ~only_classes ~st (Some (fst g)) {it = snd g; sigma = evm'} in + (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm' } + +let get_result r = + match r with + | None -> None + | Some ((gls, v), fk) -> + try ignore(v (sig_sig gls) []); assert(false) + with Found evm' -> Some (evm', fk) + +let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm tac = + match evars_to_goals p evm with + | None -> None (* This happens only because there's no evar having p *) + | Some (goals, evm') -> + let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st goals evm') in + match get_result res with + | None -> raise Not_found + | Some (evm', fk) -> Some (Evd.evars_reset_evd evm' evm, fk) + +let eauto_tac hints = + fix (or_tac (then_tac normevars_tac (hints_tac hints)) intro_tac) + +let eauto ?(only_classes=true) ?st hints g = + let gl = { it = make_autogoal ~only_classes ?st None g; sigma = project g } in + match run_tac (eauto_tac hints) gl with + | None -> raise Not_found + | Some ({it = goals; sigma = s}, valid) -> + {it = List.map fst goals; sigma = s}, valid s + +let real_eauto st hints p evd = + let rec aux evd fails = + let res, fails = + try run_on_evars ~st p evd (eauto_tac 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 (mode, depth) p evd = + let db = searchtable_map typeclasses_db in + real_eauto (Hint_db.transparent_state db) [db] p evd exception FoundTerm of constr let resolve_one_typeclass env ?(sigma=Evd.empty) gl = - let gls = { it = [ Evd.make_evar (Environ.named_context_val env) gl ] ; sigma = sigma } in - let valid x = raise (FoundTerm (fst (Refiner.extract_open_proof sigma (List.hd x)))) in - let gls', valid' = typeclasses_eauto false (true, default_eauto_depth) [] (gls, valid) in - try ignore(valid' []); assert false with FoundTerm t -> - let term = Evarutil.nf_evar (sig_sig gls') t in - if occur_existential term then raise Not_found else term - -let _ = + let gls = { it = Evd.make_evar (Environ.named_context_val env) gl; sigma = sigma } in + let hints = searchtable_map typeclasses_db in + let gls', v = eauto ~st:(Hint_db.transparent_state hints) [hints] gls in + let term = v [] in + let evd = sig_sig gls' in + let term = fst (Refiner.extract_open_proof evd term) in + let term = Evarutil.nf_evar evd term in + evd, term + +let _ = Typeclasses.solve_instanciation_problem := (fun x y z -> resolve_one_typeclass x ~sigma:y z) let has_undefined p oevd evd = Evd.fold (fun ev evi has -> has || - (evi.evar_body = Evar_empty && p ev evi && - (try Typeclasses.is_resolvable (Evd.find oevd ev) with _ -> true))) - (Evd.evars_of evd) false + (evi.evar_body = Evar_empty && snd (p oevd ev evi))) + evd false let rec merge_deps deps = function | [] -> [deps] - | hd :: tl -> - if intersects deps hd then + | hd :: tl -> + if intersects deps hd then merge_deps (Intset.union deps hd) tl else hd :: merge_deps deps tl - + +let evars_of_evi evi = + Intset.union (Evarutil.evars_of_term evi.evar_concl) + (match evi.evar_body with + | Evar_defined b -> Evarutil.evars_of_term b + | Evar_empty -> Intset.empty) + let split_evars evm = Evd.fold (fun ev evi acc -> - let deps = Intset.union (Intset.singleton ev) (Evarutil.evars_of_term evi.evar_concl) in + let deps = Intset.union (Intset.singleton ev) (evars_of_evi evi) in merge_deps deps acc) evm [] @@ -458,685 +568,113 @@ let select_evars evs evm = if Intset.mem ev evs then Evd.add acc ev evi else acc) evm Evd.empty +let is_inference_forced p ev evd = + try + let evi = Evd.find evd ev in + if evi.evar_body = Evar_empty then + if Typeclasses.is_resolvable evi + && snd (p ev evi) + then + let (loc, k) = evar_source ev evd in + match k with + | ImplicitArg (_, _, b) -> b + | QuestionMark _ -> false + | _ -> true + else true + else false + with Not_found -> true + +let is_optional p comp evd = + Intset.fold (fun ev acc -> + acc && not (is_inference_forced p ev evd)) + comp true + let resolve_all_evars debug m env p oevd do_split fail = - let oevm = Evd.evars_of oevd in - let split = if do_split then split_evars (Evd.evars_of (Evd.undefined_evars oevd)) else [Intset.empty] in - let p = if do_split then - fun comp ev evi -> (Intset.mem ev comp || not (Evd.mem oevm ev)) && p ev evi - else fun _ -> p + let split = if do_split then split_evars oevd else [Intset.empty] in + let p = if do_split then + fun comp evd ev evi -> + if evi.evar_body = Evar_empty then + (try let oevi = Evd.find oevd ev in + if Typeclasses.is_resolvable oevi then + Typeclasses.mark_unresolvable evi, (Intset.mem ev comp && + p evd ev evi) + else evi, false + with Not_found -> + Typeclasses.mark_unresolvable evi, p evd ev evi) + else evi, false + else fun _ evd ev evi -> + if evi.evar_body = Evar_empty then + try let oevi = Evd.find oevd ev in + if Typeclasses.is_resolvable oevi then + Typeclasses.mark_unresolvable evi, p evd ev evi + else evi, false + with Not_found -> + Typeclasses.mark_unresolvable evi, p evd ev evi + else evi, false + in + let rec aux p evd = + let evd' = resolve_all_evars_once debug m p evd in + if has_undefined p oevd evd' then None + else Some evd' in - let rec aux n p evd = - if has_undefined p oevm evd then - if n > 0 then - let evd' = resolve_all_evars_once debug m env p evd in - aux (pred n) p evd' - else None - else Some evd - in let rec docomp evd = function | [] -> evd | comp :: comps -> - let res = try aux 3 (p comp) evd with Not_found -> None in + let res = try aux (p comp) evd with Not_found -> None in match res with | None -> - if fail then - (* Unable to satisfy the constraints. *) - let evm = Evd.evars_of evd in - let evm = if do_split then select_evars comp evm else evm in - let _, ev = Evd.fold - (fun ev evi (b,acc) -> + if fail && (not do_split || not (is_optional (p comp evd) comp evd)) then + (* Unable to satisfy the constraints. *) + let evd = Evarutil.nf_evars evd in + let evm = if do_split then select_evars comp evd else evd in + let _, ev = Evd.fold + (fun ev evi (b,acc) -> (* focus on one instance if only one was searched for *) if class_of_constr evi.evar_concl <> None then if not b (* || do_split *) then - true, Some ev + true, Some ev else b, None else b, acc) evm (false, None) in - Typeclasses_errors.unsatisfiable_constraints env (Evd.evars_reset_evd evm evd) ev + Typeclasses_errors.unsatisfiable_constraints (Evarutil.nf_env_evar evm env) evm ev else (* Best effort: do nothing *) oevd | Some evd' -> docomp evd' comps in docomp oevd split let resolve_typeclass_evars d p env evd onlyargs split fail = - let pred = - if onlyargs then - (fun ev evi -> Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) && - Typeclasses.is_class_evar evi) - else (fun ev evi -> Typeclasses.is_class_evar evi) + let pred = + if onlyargs then + (fun evd ev evi -> Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) && + Typeclasses.is_class_evar evd evi) + else (fun evd ev evi -> Typeclasses.is_class_evar evd evi) in resolve_all_evars d p env pred evd split fail - + let solve_inst debug mode depth env evd onlyargs split fail = resolve_typeclass_evars debug (mode, depth) env evd onlyargs split fail -let _ = +let _ = Typeclasses.solve_instanciations_problem := solve_inst false true default_eauto_depth - +let set_transparency cl b = + List.iter (fun r -> + let gr = Smartlocate.global_with_alias r in + let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in + Classes.set_typeclass_transparency ev b) cl + VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings | [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ - add_hints false [typeclasses_db] (Vernacexpr.HintsTransparency (cl, true)) - ] + set_transparency cl true ] END - + VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings | [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ - add_hints false [typeclasses_db] (Vernacexpr.HintsTransparency (cl, false)) - ] + set_transparency cl false ] END -(** Typeclass-based rewriting. *) - -let morphism_class = - lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism")))) - -let morphism_proxy_class = - lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.MorphismProxy")))) - -let respect_proj = lazy (mkConst (Option.get (snd (List.hd (Lazy.force morphism_class).cl_projs)))) - -let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) - -let try_find_global_reference dir s = - let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in - Nametab.absolute_reference sp - -let try_find_reference dir s = - constr_of_global (try_find_global_reference dir s) - -let gen_constant dir s = Coqlib.gen_constant "Class_setoid" dir s -let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1") -let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2") -let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq") -let iff = lazy (gen_constant ["Init"; "Logic"] "iff") -let coq_all = lazy (gen_constant ["Init"; "Logic"] "all") -let impl = lazy (gen_constant ["Program"; "Basics"] "impl") -let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow") -let coq_id = lazy (gen_constant ["Init"; "Datatypes"] "id") - -let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive") -let reflexive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "reflexivity") -let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity") - -let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric") -let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry") -let symmetric_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "symmetry") - -let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive") -let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity") -let transitive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "transitivity") - -let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse" *) - ["Program"; "Basics"] "flip") - -let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) -(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; new_Type (); rel |]) *) - -let complement = lazy (gen_constant ["Classes"; "RelationClasses"] "complement") -let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") -let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") - -let respectful_dep = lazy (gen_constant ["Classes"; "Morphisms"] "respectful_dep") -let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") - -let equivalence = lazy (gen_constant ["Classes"; "RelationClasses"] "Equivalence") -let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") - -let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") -let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) -(* let mk_relation a = mkProd (Anonymous, a, mkProd (Anonymous, a, new_Type ())) *) - -let coq_relationT = lazy (gen_constant ["Classes";"Relations"] "relationT") - -let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive") - -let setoid_equiv = lazy (gen_constant ["Classes"; "SetoidClass"] "equiv") -let setoid_morphism = lazy (gen_constant ["Classes"; "SetoidClass"] "setoid_morphism") -let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive") - -let setoid_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "SetoidRelation") - -let arrow_morphism a b = - if isprop a && isprop b then - Lazy.force impl - else - mkApp(Lazy.force arrow, [|a;b|]) - -let setoid_refl pars x = - applistc (Lazy.force setoid_refl_proj) (pars @ [x]) - -let morphism_type = lazy (constr_of_global (Lazy.force morphism_class).cl_impl) - -let morphism_proxy_type = lazy (constr_of_global (Lazy.force morphism_proxy_class).cl_impl) - -let is_applied_setoid_relation t = - match kind_of_term t with - | App (c, args) when Array.length args >= 2 -> - let head = if isApp c then fst (destApp c) else c in - if eq_constr (Lazy.force coq_eq) head then false - else (try - let evd, evar = Evarutil.new_evar (Evd.create_evar_defs Evd.empty) (Global.env()) (new_Type ()) in - let inst = mkApp (Lazy.force setoid_relation, [| evar; c |]) in - ignore(Typeclasses.resolve_one_typeclass (Global.env()) (Evd.evars_of evd) inst); - true - with _ -> false) - | _ -> false - -let _ = - Equality.register_is_applied_setoid_relation is_applied_setoid_relation - -let split_head = function - hd :: tl -> hd, tl - | [] -> assert(false) - -let build_signature isevars env m (cstrs : 'a option list) (finalcstr : 'a Lazy.t option) (f : 'a -> constr) = - let new_evar isevars env t = - Evarutil.e_new_evar isevars env - (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t - in - let mk_relty ty obj = - match obj with - | None -> - let relty = mk_relation ty in - new_evar isevars env relty - | Some x -> f x - in - let rec aux env ty l = - let t = Reductionops.whd_betadeltaiota env (Evd.evars_of !isevars) ty in - match kind_of_term t, l with - | Prod (na, ty, b), obj :: cstrs -> - if dependent (mkRel 1) b then - let (b, arg, evars) = aux (Environ.push_rel (na, None, ty) env) b cstrs in - let ty = Reductionops.nf_betaiota (Evd.evars_of !isevars) ty in - let pred = mkLambda (na, ty, b) in - let liftarg = mkLambda (na, ty, arg) in - let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in - mkProd(na, ty, b), arg', (ty, None) :: evars - else - let (b', arg, evars) = aux env (subst1 mkProp b) cstrs in - let ty = Reductionops.nf_betaiota(Evd.evars_of !isevars) ty in - let relty = mk_relty ty obj in - let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in - mkProd(na, ty, b), newarg, (ty, Some relty) :: evars - | _, obj :: _ -> anomaly "build_signature: not enough products" - | _, [] -> - (match finalcstr with - None -> - let t = Reductionops.nf_betaiota(Evd.evars_of !isevars) ty in - let rel = mk_relty t None in - t, rel, [t, Some rel] - | Some codom -> let (t, rel) = Lazy.force codom in - t, rel, [t, Some rel]) - in aux env m cstrs - -let morphism_proof env evars carrier relation x = - let goal = - mkApp (Lazy.force morphism_proxy_type, [| carrier ; relation; x |]) - in Evarutil.e_new_evar evars env goal - -let find_class_proof proof_type proof_method env evars carrier relation = - try - let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in - Typeclasses.resolve_one_typeclass env evars goal - with e when Logic.catchable_exception e -> raise Not_found - -let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env -let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env -let get_transitive_proof env = find_class_proof transitive_type transitive_proof env - -exception FoundInt of int - -let array_find (arr: 'a array) (pred: int -> 'a -> bool): int = - try - for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (FoundInt i) done; - raise Not_found - with FoundInt i -> i - -let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars = - let morph_instance, proj, sigargs, m', args, args' = - let first = try (array_find args' (fun i b -> b <> None)) with Not_found -> raise (Invalid_argument "resolve_morphism") in - let morphargs, morphobjs = array_chop first args in - let morphargs', morphobjs' = array_chop first args' in - let appm = mkApp(m, morphargs) in - let appmtype = Typing.type_of env sigma appm in - let cstrs = List.map (function None -> None | Some (_, (a, r, _, _)) -> Some (a, r)) (Array.to_list morphobjs') in - let appmtype', signature, sigargs = build_signature evars env appmtype cstrs cstr (fun (a, r) -> r) in - let cl_args = [| appmtype' ; signature ; appm |] in - let app = mkApp (Lazy.force morphism_type, cl_args) in - let morph = Evarutil.e_new_evar evars env app in - morph, morph, sigargs, appm, morphobjs, morphobjs' - in - let projargs, respars, typeargs = - array_fold_left2 - (fun (acc, sigargs, typeargs') x y -> - let (carrier, relation), sigargs = split_head sigargs in - match relation with - | Some relation -> - (match y with - | None -> - let proof = morphism_proof env evars carrier relation x in - [ proof ; x ; x ] @ acc, sigargs, x :: typeargs' - | Some (p, (_, _, _, t')) -> - [ p ; t'; x ] @ acc, sigargs, t' :: typeargs') - | None -> - if y <> None then error "Cannot rewrite the argument of a dependent function"; - x :: acc, sigargs, x :: typeargs') - ([], sigargs, []) args args' - in - let proof = applistc proj (List.rev projargs) in - let newt = applistc m' (List.rev typeargs) in - match respars with - [ a, Some r ] -> (proof, (a, r, oldt, fnewt newt)) - | _ -> assert(false) - -(* Adapted from setoid_replace. *) - -type hypinfo = { - cl : clausenv; - prf : constr; - car : constr; - rel : constr; - l2r : bool; - c1 : constr; - c2 : constr; - c : constr option; - abs : (constr * types) option; -} - -let evd_convertible env evd x y = - try ignore(Evarconv.the_conv_x env x y evd); true - with _ -> false - -let decompose_setoid_eqhyp env sigma c left2right = - let ctype = Typing.type_of env sigma c in - let find_rel ty = - let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) 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 - let ty1, ty2 = - Typing.mtype_of env eqclause.evd c1, Typing.mtype_of env eqclause.evd c2 - in - if not (evd_convertible env eqclause.evd ty1 ty2) then None - else - Some { cl=eqclause; prf=(Clenv.clenv_value eqclause); - car=ty1; rel=mkApp (equiv, Array.of_list others); - l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None } - in - match find_rel ctype with - | Some c -> c - | None -> - let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' ctx) with - | Some c -> c - | None -> error "The term does not end with an applied homogeneous relation." - -let rewrite_unif_flags = { - Unification.modulo_conv_on_closed_terms = None; - Unification.use_metas_eagerly = true; - Unification.modulo_delta = empty_transparent_state; -} - -let conv_transparent_state = (Idpred.empty, Cpred.full) - -let rewrite2_unif_flags = { - Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; - Unification.use_metas_eagerly = true; - Unification.modulo_delta = empty_transparent_state; -} - -let convertible env evd x y = - Reductionops.is_conv env (Evd.evars_of evd) x y - -let allowK = true - -let refresh_hypinfo env sigma hypinfo = - if !hypinfo.abs = None then - let {l2r=l2r; c = c;cl=cl} = !hypinfo in - match c with - | Some c -> - (* Refresh the clausenv to not get the same meta twice in the goal. *) - hypinfo := decompose_setoid_eqhyp env (Evd.evars_of cl.evd) c l2r; - | _ -> () - else () - -let unify_eqn env sigma hypinfo t = - if isEvar t then None - else try - let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in - let env', prf, c1, c2, car, rel = - let left = if l2r then c1 else c2 in - match abs with - Some (absprf, absprfty) -> - let env' = clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl in - env', prf, c1, c2, car, rel - | None -> - let env' = - try clenv_unify allowK ~flags:rewrite_unif_flags - CONV left t cl - with Pretype_errors.PretypeError _ -> - (* For Ring essentially, only when doing setoid_rewrite *) - clenv_unify allowK ~flags:rewrite2_unif_flags - CONV left t cl - in - let env' = - let mvs = clenv_dependent false env' in - clenv_pose_metas_as_evars env' mvs - in - let evd' = Typeclasses.resolve_typeclasses ~fail:false env'.env env'.evd in - let env' = { env' with evd = evd' } in - let nf c = Evarutil.nf_evar (Evd.evars_of evd') (Clenv.clenv_nf_meta env' c) in - let c1 = nf c1 and c2 = nf c2 - and car = nf car and rel = nf rel - and prf = nf (Clenv.clenv_value env') in - let ty1 = Typing.mtype_of env'.env env'.evd c1 - and ty2 = Typing.mtype_of env'.env env'.evd c2 - in - if convertible env env'.evd ty1 ty2 then ( - if occur_meta prf then refresh_hypinfo env sigma hypinfo; - env', prf, c1, c2, car, rel) - else raise Reduction.NotConvertible - in - let res = - if l2r then (prf, (car, rel, c1, c2)) - else - try (mkApp (get_symmetric_proof env Evd.empty car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1)) - with Not_found -> - (prf, (car, inverse car rel, c2, c1)) - in Some (env', res) - with e when catchable e -> None - -let unfold_impl t = - match kind_of_term t with - | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> - mkProd (Anonymous, a, lift 1 b) - | _ -> assert false - -let unfold_id t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_id) *) -> b - | _ -> assert false - -let unfold_all t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - -let decomp_prod env evm n c = - snd (Reductionops.decomp_n_prod env evm n c) - -let rec decomp_pointwise n c = - if n = 0 then c - else - match kind_of_term c with - | App (pointwise, [| a; b; relb |]) -> decomp_pointwise (pred n) relb - | _ -> raise Not_found - -let lift_cstr env sigma evars args cstr = - let cstr () = - let start = - match cstr with - | Some codom -> Lazy.force codom - | None -> let car = Evarutil.e_new_evar evars env (new_Type ()) in - let rel = Evarutil.e_new_evar evars env (mk_relation car) in - (car, rel) - in - Array.fold_right - (fun arg (car, rel) -> - let ty = Typing.type_of env sigma arg in - let car' = mkProd (Anonymous, ty, car) in - let rel' = mkApp (Lazy.force pointwise_relation, [| ty; car; rel |]) in - (car', rel')) - args start - in Some (Lazy.lazy_from_fun cstr) - -let unlift_cstr env sigma = function - | None -> None - | Some codom -> - let cstr () = - let car, rel = Lazy.force codom in - decomp_prod env sigma 1 car, decomp_pointwise 1 rel - in Some (Lazy.lazy_from_fun cstr) - -type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } - -let default_flags = { under_lambdas = true; on_morphisms = true; } - -let build_new gl env sigma flags loccs hypinfo concl cstr evars = - let (nowhere_except_in,occs) = loccs in - let is_occ occ = - if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in - let rec aux env t occ cstr = - let unif = unify_eqn env sigma hypinfo t in - let occ = if unif = None then occ else succ occ in - match unif with - | Some (env', (prf, hypinfo as x)) when is_occ occ -> - begin - evars := Evd.evar_merge !evars - (Evd.evars_of (Evd.undefined_evars (Evarutil.nf_evar_defs env'.evd))); - match cstr with - | None -> Some x, occ - | Some _ -> - let (car, r, orig, dest) = hypinfo in - let res = - resolve_morphism env sigma t ~fnewt:unfold_id - (mkApp (Lazy.force coq_id, [| car |])) - [| orig |] [| Some x |] cstr evars - in Some res, occ - end - | _ -> - match kind_of_term t with - | App (m, args) -> - let rewrite_args occ = - let args', occ = - Array.fold_left - (fun (acc, occ) arg -> let res, occ = aux env arg occ None in (res :: acc, occ)) - ([], occ) args - in - let res = - if List.for_all (fun x -> x = None) args' then None - else - let args' = Array.of_list (List.rev args') in - (Some (resolve_morphism env sigma t m args args' cstr evars)) - in res, occ - in - if flags.on_morphisms then - let m', occ = aux env m occ (lift_cstr env sigma evars args cstr) in - match m' with - | None -> rewrite_args occ (* Standard path, try rewrite on arguments *) - | Some (prf, (car, rel, c1, c2)) -> - (* We rewrote the function and get a proof of pointwise rel for the arguments. - We just apply it. *) - let nargs = Array.length args in - let res = - mkApp (prf, args), - (decomp_prod env (Evd.evars_of !evars) nargs car, - decomp_pointwise nargs rel, mkApp(c1, args), mkApp(c2, args)) - in Some res, occ - else rewrite_args occ - - | Prod (n, x, b) when not (dependent (mkRel 1) b) -> - let x', occ = aux env x occ None in -(* if x' = None && flags.under_lambdas then *) -(* let lam = mkLambda (n, x, b) in *) -(* let lam', occ = aux env lam occ None in *) -(* let res = *) -(* match lam' with *) -(* | None -> None *) -(* | Some (prf, (car, rel, c1, c2)) -> *) -(* Some (resolve_morphism env sigma t *) -(* ~fnewt:unfold_all *) -(* (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *) -(* cstr evars) *) -(* in res, occ *) -(* else *) - let b = subst1 mkProp b in - let b', occ = aux env b occ None in - let res = - if x' = None && b' = None then None - else - Some (resolve_morphism env sigma t - ~fnewt:unfold_impl - (arrow_morphism (Typing.type_of env sigma x) (Typing.type_of env sigma b)) - [| x ; b |] [| x' ; b' |] - cstr evars) - in res, occ - - | Prod (n, ty, b) -> - let lam = mkLambda (n, ty, b) in - let lam', occ = aux env lam occ None in - let res = - match lam' with - | None -> None - | Some (prf, (car, rel, c1, c2)) -> - Some (resolve_morphism env sigma t - ~fnewt:unfold_all - (Lazy.force coq_all) [| ty ; lam |] [| None; lam' |] - cstr evars) - in res, occ - - | Lambda (n, t, b) when flags.under_lambdas -> - let env' = Environ.push_rel (n, None, t) env in - refresh_hypinfo env' sigma hypinfo; - let b', occ = aux env' b occ (unlift_cstr env sigma cstr) in - let res = - match b' with - | None -> None - | Some (prf, (car, rel, c1, c2)) -> - let prf' = mkLambda (n, t, prf) in - let car' = mkProd (n, t, car) in - let rel' = mkApp (Lazy.force pointwise_relation, [| t; car; rel |]) in - let c1' = mkLambda(n, t, c1) and c2' = mkLambda (n, t, c2) in - Some (prf', (car', rel', c1', c2')) - in res, occ - | _ -> None, occ - in - let eq,nbocc_min_1 = aux env concl 0 cstr in - let rest = List.filter (fun o -> o > nbocc_min_1) occs in - if rest <> [] then error_invalid_occurrence rest; - eq - -let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause gl = - let concl, is_hyp = - match clause with - Some ((_, id), _) -> pf_get_hyp_typ gl id, Some id - | None -> pf_concl gl, None - in - let cstr = - let sort = mkProp in - let impl = Lazy.force impl in - match is_hyp with - | None -> (sort, inverse sort impl) - | Some _ -> (sort, impl) - in - let sigma = project gl in - let evars = ref (Evd.create_evar_defs sigma) in - let env = pf_env gl in - let eq = build_new gl env sigma flags occs hypinfo concl (Some (Lazy.lazy_from_val cstr)) evars - in - match eq with - | Some (p, (_, _, oldt, newt)) -> - (try - evars := Typeclasses.resolve_typeclasses env ~split:false ~fail:true !evars; - let p = Evarutil.nf_isevar !evars p in - let newt = Evarutil.nf_isevar !evars newt in - let undef = Evd.undefined_evars !evars in - let abs = Option.map (fun (x, y) -> Evarutil.nf_isevar !evars x, - Evarutil.nf_isevar !evars y) !hypinfo.abs in - let rewtac = - match is_hyp with - | Some id -> - let term = - match abs with - | None -> p - | Some (t, ty) -> - mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) - in - cut_replacing id newt - (fun x -> Tacmach.refine_no_check (mkApp (term, [| mkVar id |]))) - | None -> - (match abs with - | None -> - let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in - tclTHENLAST - (Tacmach.internal_cut_no_check false name newt) - (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p)) - | Some (t, ty) -> - Tacmach.refine_no_check - (mkApp (mkLambda (Name (id_of_string "newt"), newt, - mkLambda (Name (id_of_string "lemma"), ty, - mkApp (p, [| mkRel 2 |]))), - [| mkMeta goal_meta; t |]))) - in - let evartac = - let evd = Evd.evars_of undef in - if not (evd = Evd.empty) then Refiner.tclEVARS (Evd.merge sigma evd) - else tclIDTAC - in tclTHENLIST [evartac; rewtac] gl - with - | Stdpp.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e))) - | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> - tclFAIL 0 (str" setoid rewrite failed: unable to satisfy the rewriting constraints." - ++ fnl () ++ Himsg.explain_typeclass_error env e) gl) - (* | Not_found -> *) - (* tclFAIL 0 (str" setoid rewrite failed: unable to satisfy the rewriting constraints.") gl) *) - | None -> - let {l2r=l2r; c1=x; c2=y} = !hypinfo in - raise (Pretype_errors.PretypeError - (pf_env gl, - Pretype_errors.NoOccurrenceFound ((if l2r then x else y), is_hyp))) - (* tclFAIL 1 (str"setoid rewrite failed") gl *) - -let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause gl = - cl_rewrite_clause_aux ~flags hypinfo goal_meta occs clause gl - -let cl_rewrite_clause (evm,c) left2right occs clause gl = - init_setoid (); - let meta = Evarutil.new_meta() in - let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in - let env = pf_env gl in - let evars = Evd.merge (project gl) evm in - let hypinfo = ref (decompose_setoid_eqhyp env evars c left2right) in - cl_rewrite_clause_aux hypinfo meta occs clause gl - open Genarg open Extraargs -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) - -TACTIC EXTEND class_rewrite -| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), [])) ] -| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), [])) ] -| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some (([],id), [])) ] -| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ] -| [ "clrewrite" orient(o) open_constr(c) ] -> [ cl_rewrite_clause c o all_occurrences None ] -END - - -let clsubstitute o c = - let is_tac id = match kind_of_term (snd c) with Var id' when id' = id -> true | _ -> false in - Tacticals.onAllClauses - (fun cl -> - match cl with - | Some ((_,id),_) when is_tac id -> tclIDTAC - | _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl)) - -TACTIC EXTEND substitute -| [ "substitute" orient(o) open_constr(c) ] -> [ clsubstitute o c ] -END - let pr_debug _prc _prlc _prt b = if b then Pp.str "debug" else Pp.mt() @@ -1148,9 +686,9 @@ END let pr_mode _prc _prlc _prt m = match m with Some b -> - if b then Pp.str "depth-first" else Pp.str "breadth-fist" + if b then Pp.str "depth-first" else Pp.str "breadth-fist" | None -> Pp.mt() - + ARGUMENT EXTEND search_mode TYPED AS bool option PRINTED BY pr_mode | [ "dfs" ] -> [ Some true ] | [ "bfs" ] -> [ Some false ] @@ -1160,13 +698,14 @@ 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 - + VERNAC COMMAND EXTEND Typeclasses_Settings - | [ "Typeclasses" "eauto" ":=" debug(d) search_mode(s) depth(depth) ] -> [ + | [ "Typeclasses" "eauto" ":=" debug(d) search_mode(s) depth(depth) ] -> [ + typeclasses_debug := d; let mode = match s with Some t -> t | None -> true in let depth = match depth with Some i -> i | None -> default_eauto_depth in Typeclasses.solve_instanciations_problem := @@ -1174,661 +713,31 @@ VERNAC COMMAND EXTEND Typeclasses_Settings ] 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 _ -> None) dbs in + let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in + eauto ~only_classes ~st dbs gl + with Not_found -> tclFAIL 0 (str" typeclasses eauto failed") gl + TACTIC EXTEND typeclasses_eauto -| [ "typeclasses" "eauto" debug(d) search_mode(s) depth(depth) ] -> [ - let mode = match s with Some t -> t | None -> true in - let depth = match depth with Some i -> i | None -> default_eauto_depth in - fun gl -> - let gls = {it = [sig_it gl]; sigma = project gl} in - let vals v = List.hd v in - try typeclasses_eauto d (mode, depth) [] (gls, vals) - with Not_found -> tclFAIL 0 (str" typeclasses eauto failed") gl ] -END - - -(* fun gl -> *) -(* let env = pf_env gl in *) -(* let sigma = project gl in *) -(* let proj = sig_it gl in *) -(* let evd = Evd.create_evar_defs (Evd.add Evd.empty 1 proj) in *) -(* let mode = match s with Some t -> t | None -> true in *) -(* let depth = match depth with Some i -> i | None -> default_eauto_depth in *) -(* match resolve_typeclass_evars d (mode, depth) env evd false with *) -(* | Some evd' -> *) -(* let goal = Evd.find (Evd.evars_of evd') 1 in *) -(* (match goal.evar_body with *) -(* | Evar_empty -> tclIDTAC gl *) -(* | Evar_defined b -> refine b gl) *) -(* | None -> tclIDTAC gl *) -(* ] *) - -let _ = - Classes.refine_ref := Refine.refine - -(* Compatibility with old Setoids *) - -TACTIC EXTEND setoid_rewrite - [ "setoid_rewrite" orient(o) open_constr(c) ] - -> [ cl_rewrite_clause c o all_occurrences None ] - | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) ] -> - [ cl_rewrite_clause c o all_occurrences (Some (([],id), []))] - | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) ] -> - [ cl_rewrite_clause c o (occurrences_of occ) None] - | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id)] -> - [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), []))] - | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ)] -> - [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), []))] +| [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ typeclasses_eauto l ] +| [ "typeclasses" "eauto" ] -> [ typeclasses_eauto ~only_classes:true [typeclasses_db] ] END -(* let solve_obligation lemma = *) -(* tclTHEN (Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor None))) *) -(* (eapply_with_bindings (Constrintern.interp_constr Evd.empty (Global.env()) lemma, NoBindings)) *) - -let mkappc s l = CAppExpl (dummy_loc,(None,(Libnames.Ident (dummy_loc,id_of_string s))),l) - -let declare_an_instance n s args = - ((dummy_loc,Name n), Explicit, - CAppExpl (dummy_loc, (None, Qualid (dummy_loc, qualid_of_string s)), - args)) - -let declare_instance a aeq n s = declare_an_instance n s [a;aeq] - -let anew_instance binders instance fields = - new_instance binders instance (CRecord (dummy_loc,None,fields)) ~generalize:false None - -let require_library dirpath = - let qualid = (dummy_loc, Libnames.qualid_of_dirpath (Libnames.dirpath_of_string dirpath)) in - Library.require_library [qualid] (Some false) - -let declare_instance_refl binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance binders instance - [((dummy_loc,id_of_string "reflexivity"),lemma)] - -let declare_instance_sym binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" - in anew_instance binders instance - [((dummy_loc,id_of_string "symmetry"),lemma)] - -let declare_instance_trans binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" - in anew_instance binders instance - [((dummy_loc,id_of_string "transitivity"),lemma)] - -let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None))) - -let declare_relation ?(binders=[]) a aeq n refl symm trans = - init_setoid (); - let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.SetoidTactics.SetoidRelation" - in ignore(anew_instance binders instance []); - match (refl,symm,trans) with - (None, None, None) -> () - | (Some lemma1, None, None) -> - ignore (declare_instance_refl binders a aeq n lemma1) - | (None, Some lemma2, None) -> - ignore (declare_instance_sym binders a aeq n lemma2) - | (None, None, Some lemma3) -> - ignore (declare_instance_trans binders a aeq n lemma3) - | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl binders a aeq n lemma1); - ignore (declare_instance_sym binders a aeq n lemma2) - | (Some lemma1, None, Some lemma3) -> - let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in - let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" - in ignore( - anew_instance binders instance - [((dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1); - ((dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)]) - | (None, Some lemma2, Some lemma3) -> - let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" - in ignore( - anew_instance binders instance - [((dummy_loc,id_of_string "PER_Symmetric"), lemma2); - ((dummy_loc,id_of_string "PER_Transitive"),lemma3)]) - | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in - let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance binders instance - [((dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1); - ((dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2); - ((dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)]) - -type 'a binders_let_argtype = (local_binder list, 'a) Genarg.abstract_argument_type - -let (wit_binders_let : Genarg.tlevel binders_let_argtype), - (globwit_binders_let : Genarg.glevel binders_let_argtype), - (rawwit_binders_let : Genarg.rlevel binders_let_argtype) = - Genarg.create_arg "binders_let" - -open Pcoq.Constr - -VERNAC COMMAND EXTEND AddRelation - | [ "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 +let _ = Classes.refine_ref := Refine.refine -VERNAC COMMAND EXTEND AddRelation2 - [ "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 - [ "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 - -VERNAC COMMAND EXTEND AddParametricRelation - | [ "Add" "Parametric" "Relation" binders_let(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_let(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_let(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None None ] -END - -VERNAC COMMAND EXTEND AddParametricRelation2 - [ "Add" "Parametric" "Relation" binders_let(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_let(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 - [ "Add" "Parametric" "Relation" binders_let(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_let(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_let(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 - -let mk_qualid s = - Libnames.Qualid (dummy_loc, Libnames.qualid_of_string s) - -let cHole = CHole (dummy_loc, None) - -open Entries -open Libnames - -let respect_projection r ty = - let ctx, inst = Sign.decompose_prod_assum ty in - let mor, args = destApp inst in - let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in - let app = mkApp (Lazy.force respect_proj, - Array.append args [| instarg |]) in - it_mkLambda_or_LetIn app ctx - -let declare_projection n instance_id r = - let ty = Global.type_of_global r in - let c = constr_of_global r in - let term = respect_projection c ty in - let typ = Typing.type_of (Global.env ()) Evd.empty term in - let ctx, typ = Sign.decompose_prod_assum typ in - let typ = - let n = - let rec aux t = - match kind_of_term t with - App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) -> - succ (aux rel') - | _ -> 0 - in - let init = - match kind_of_term typ with - App (f, args) when eq_constr f (Lazy.force respectful) -> - mkApp (f, fst (array_chop (Array.length args - 2) args)) - | _ -> typ - in aux init - in - let ctx,ccl = Reductionops.decomp_n_prod (Global.env()) Evd.empty (3 * n) typ - in it_mkProd_or_LetIn ccl ctx - in - let typ = it_mkProd_or_LetIn typ ctx in - let cst = - { const_entry_body = term; - const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_boxed = false } - in - ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) - -let build_morphism_signature m = - let env = Global.env () in - let m = Constrintern.interp_constr Evd.empty env m in - let t = Typing.type_of env Evd.empty m in - let isevars = ref (Evd.create_evar_defs Evd.empty) in - let cstrs = - let rec aux t = - match kind_of_term t with - | Prod (na, a, b) -> - None :: aux b - | _ -> [] - in aux t - in - let t', sig_, evars = build_signature isevars env t cstrs None snd in - let _ = List.iter - (fun (ty, rel) -> - Option.iter (fun rel -> - let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in - ignore (Evarutil.e_new_evar isevars env default)) - rel) - evars - in - let morph = - mkApp (Lazy.force morphism_type, [| t; sig_; m |]) - in - let evd = - Typeclasses.resolve_typeclasses ~fail:true ~onlyargs:false env !isevars in - let m = Evarutil.nf_isevar evd morph in - Evarutil.check_evars env Evd.empty evd m; m - -let default_morphism sign m = - let env = Global.env () in - let isevars = ref (Evd.create_evar_defs Evd.empty) in - let t = Typing.type_of env Evd.empty m in - let _, sign, evars = - build_signature isevars env t (fst sign) (snd sign) (fun (ty, rel) -> rel) - in - let morph = - mkApp (Lazy.force morphism_type, [| t; sign; m |]) - in - let mor = resolve_one_typeclass env morph in - mor, respect_projection mor morph - -let add_setoid binders a aeq t n = - init_setoid (); - let _lemma_refl = declare_instance_refl binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym = declare_instance_sym binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans = declare_instance_trans binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance binders instance - [((dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); - ((dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - ((dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) - -let add_morphism_infer m n = - init_setoid (); - let instance_id = add_suffix n "_Morphism" in - let instance = build_morphism_signature m in - if Lib.is_modtype () then - let cst = Declare.declare_internal_constant instance_id - (Entries.ParameterEntry (instance,false), Decl_kinds.IsAssumption Decl_kinds.Logical) - in - add_instance (Typeclasses.new_instance (Lazy.force morphism_class) None false cst); - declare_projection n instance_id (ConstRef cst) - else - let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in - Flags.silently - (fun () -> - Command.start_proof instance_id kind instance - (fun _ -> function - Libnames.ConstRef cst -> - add_instance (Typeclasses.new_instance - (Lazy.force morphism_class) None false cst); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false); - Pfedit.by (Tacinterp.interp <:tactic< Coq.Classes.SetoidTactics.add_morphism_tactic>>)) (); - Flags.if_verbose (fun x -> msg (Printer.pr_open_subgoals x)) () - -let add_morphism binders m s n = - init_setoid (); - let instance_id = add_suffix n "_Morphism" in - let instance = - ((dummy_loc,Name instance_id), Explicit, - CAppExpl (dummy_loc, - (None, Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Classes.Morphisms.Morphism")), - [cHole; s; m])) - in - let tac = Tacinterp.interp <:tactic<add_morphism_tactic>> in - ignore(new_instance binders instance (CRecord (dummy_loc,None,[])) - ~generalize:false ~tac ~hook:(fun cst -> declare_projection n instance_id (ConstRef cst)) None) - -VERNAC COMMAND EXTEND AddSetoid1 - [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ add_setoid [] a aeq t n ] - | [ "Add" "Parametric" "Setoid" binders_let(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ add_setoid binders a aeq t n ] - | [ "Add" "Morphism" constr(m) ":" ident(n) ] -> - [ add_morphism_infer m n ] - | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] -> - [ add_morphism [] m s n ] - | [ "Add" "Parametric" "Morphism" binders_let(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] -> - [ add_morphism binders m s n ] -END - -(** Bind to "rewrite" too *) - -(** Taken from original setoid_replace, to emulate the old rewrite semantics where - lemmas are first instantiated and then rewrite proceeds. *) - -let check_evar_map_of_evars_defs evd = - let metas = Evd.meta_list evd in - let check_freemetas_is_empty rebus = - Evd.Metaset.iter - (fun m -> - if Evd.meta_defined evd m then () else - raise - (Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m]))) - in - List.iter - (fun (_,binding) -> - match binding with - Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> - check_freemetas_is_empty rebus freemetas - | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_), - {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> - check_freemetas_is_empty rebus1 freemetas1 ; - check_freemetas_is_empty rebus2 freemetas2 - ) metas - -let unification_rewrite l2r c1 c2 cl car rel but gl = - let env = pf_env gl in - let (evd',c') = - try - (* ~flags:(false,true) to allow to mark occurrences that must not be - rewritten simply by replacing them with let-defined definitions - in the context *) - Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env ((if l2r then c1 else c2),but) cl.evd - with - Pretype_errors.PretypeError _ -> - (* ~flags:(true,true) to make Ring work (since it really - exploits conversion) *) - Unification.w_unify_to_subterm ~flags:rewrite2_unif_flags - env ((if l2r then c1 else c2),but) cl.evd - in - let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in - let cl' = {cl with evd = evd'} in - let cl' = - let mvs = clenv_dependent false cl' in - clenv_pose_metas_as_evars cl' mvs - in - let nf c = Evarutil.nf_evar (Evd.evars_of cl'.evd) (Clenv.clenv_nf_meta cl' c) in - let c1 = nf c1 and c2 = nf c2 and car = nf car and rel = nf rel in - check_evar_map_of_evars_defs cl'.evd; - let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in - let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in - {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)} - -let get_hyp gl (evm,c) clause l2r = - let evars = Evd.merge (project gl) evm in - let hi = decompose_setoid_eqhyp (pf_env gl) evars c l2r in - let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in - unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl - -let general_rewrite_flags = { under_lambdas = false; on_morphisms = false } - -let general_s_rewrite cl l2r occs c ~new_goals gl = - let meta = Evarutil.new_meta() in - let hypinfo = ref (get_hyp gl c cl l2r) in - let cl' = Option.map (fun id -> (([],id), [])) cl in - cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs cl' gl -(* if fst c = Evd.empty || fst c == project gl then tac gl *) -(* else *) -(* let evars = Evd.merge (fst c) (project gl) in *) -(* tclTHEN (Refiner.tclEVARS evars) tac gl *) - -let general_s_rewrite_clause x = - init_setoid (); - match x with - | None -> general_s_rewrite None - | Some id -> general_s_rewrite (Some id) - -let _ = Equality.register_general_setoid_rewrite_clause general_s_rewrite_clause - -let is_loaded d = - let d' = List.map id_of_string d in - let dir = make_dirpath (List.rev d') in - Library.library_is_loaded dir - -let try_loaded f gl = - if is_loaded ["Coq";"Classes";"RelationClasses"] then f gl - else tclFAIL 0 (str"You need to require Coq.Classes.RelationClasses first") gl - -let try_classes t gls = - try t gls - with (Pretype_errors.PretypeError _) as e -> raise e - -TACTIC EXTEND try_classes - [ "try_classes" tactic(t) ] -> [ try_classes (snd t) ] -END - -open Rawterm -open Environ -open Refiner - -let typeclass_app evm gl ?(bindings=NoBindings) c ty = - let nprod = nb_prod (pf_concl gl) in - let n = nb_prod ty - nprod in - if n<0 then error "Apply_tc: theorem has not enough premisses."; - Refiner.tclTHEN (Refiner.tclEVARS evm) - (fun gl -> - let clause = make_clenv_binding_apply gl (Some n) (c,ty) bindings in - let cl' = evar_clenv_unique_resolver true ~flags:default_unify_flags clause gl in - let evd' = Typeclasses.resolve_typeclasses cl'.env ~fail:true cl'.evd in - tclTHEN (Clenvtac.clenv_refine true {cl' with evd = evd'}) - tclNORMEVAR gl) gl - -open Tacinterp -open Pretyping - -let my_ist = - { lfun = []; - avoid_ids = []; - debug = Tactic_debug.DebugOff; - trace = [] } - -let rawconstr_and_expr (evd, c) = c - -let rawconstr_and_expr_of_rawconstr_bindings = function - | NoBindings -> NoBindings - | ImplicitBindings l -> ImplicitBindings (List.map rawconstr_and_expr l) - | ExplicitBindings l -> ExplicitBindings (List.map (fun (l,b,c) -> (l,b,rawconstr_and_expr c)) l) - -let my_glob_sign sigma env = { - ltacvars = [], [] ; - ltacrecvars = []; - gsigma = sigma ; - genv = env } - -let typeclass_app_constrexpr t ?(bindings=NoBindings) gl = - let env = pf_env gl in - let evars = ref (create_evar_defs (project gl)) in - let gs = my_glob_sign (project gl) env in - let t', bl = Tacinterp.intern_constr_with_bindings gs (t,bindings) in - let j = Pretyping.Default.understand_judgment_tcc evars env (fst t') in - let bindings = Tacinterp.interp_bindings my_ist gl bl in - typeclass_app (Evd.evars_of !evars) gl ~bindings:bindings j.uj_val j.uj_type - -let typeclass_app_raw (_,t) gl = - let env = pf_env gl in - let evars = ref (create_evar_defs (project gl)) in - let j = Pretyping.Default.understand_judgment_tcc evars env t in - typeclass_app (Evd.evars_of !evars) gl j.uj_val j.uj_type - -let pr_gen prc _prlc _prtac c = prc c - -let pr_ceb _prc _prlc _prtac raw = mt () - -let interp_constr_expr_bindings _ _ t = t - -let intern_constr_expr_bindings ist t = t - -open Pcoq.Tactic - -type constr_expr_bindings = constr_expr with_bindings - -ARGUMENT EXTEND constr_expr_bindings - TYPED AS constr_expr_bindings - PRINTED BY pr_ceb - - INTERPRETED BY interp_constr_expr_bindings - GLOBALIZED BY intern_constr_expr_bindings - - - [ constr_with_bindings(c) ] -> [ c ] -END - -TACTIC EXTEND apply_typeclasses -[ "typeclass_app" constr_expr_bindings(t) ] -> [ typeclass_app_constrexpr (fst t) ~bindings:(snd t) ] -END -TACTIC EXTEND apply_typeclasses_abbrev -[ "tcapp" raw(t) ] -> [ typeclass_app_raw t ] -END - -(* [setoid_]{reflexivity,symmetry,transitivity} tactics *) - -let not_declared env ty rel = - tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++ - str ty ++ str" relation. Maybe you need to require the Setoid library") - -let relation_of_constr env c = - match kind_of_term c with - | App (f, args) when Array.length args >= 2 -> - let relargs, args = array_chop (Array.length args - 2) args in - mkApp (f, relargs), args - | _ -> errorlabstrm "relation_of_constr" - (str "The term " ++ Printer.pr_constr_env env c ++ str" is not an applied relation.") - -let setoid_proof gl ty fn fallback = - let env = pf_env gl in - try - let rel, args = relation_of_constr env (pf_concl gl) in - let evm, car = project gl, pf_type_of gl args.(0) in - fn env evm car rel gl - with e -> - match fallback gl with - | Some tac -> tac gl - | None -> - match e with - | Not_found -> - let rel, args = relation_of_constr env (pf_concl gl) in - not_declared env ty rel gl - | _ -> raise e - -let setoid_reflexivity gl = - setoid_proof gl "reflexive" - (fun env evm car rel -> apply (get_reflexive_proof env evm car rel)) - (reflexivity_red true) - -let setoid_symmetry gl = - setoid_proof gl "symmetric" - (fun env evm car rel -> apply (get_symmetric_proof env evm car rel)) - (symmetry_red true) - -let setoid_transitivity c gl = - setoid_proof gl "transitive" - (fun env evm car rel -> - apply_with_bindings - ((get_transitive_proof env evm car rel), - Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ])) - (transitivity_red true c) - -(* - let setoid_proof gl ty ?(bindings=NoBindings) meth fallback = - try - typeclass_app_constrexpr - (CRef (Qualid (dummy_loc, Nametab.shortest_qualid_of_global Idset.empty - (Lazy.force meth)))) ~bindings gl - with Not_found | Typeclasses_errors.TypeClassError (_, _) | - Stdpp.Exc_located (_, Typeclasses_errors.TypeClassError (_, _)) -> - match fallback gl with - | Some tac -> tac gl - | None -> - let env = pf_env gl in - let rel, args = relation_of_constr env (pf_concl gl) in - not_declared env ty rel gl - -let setoid_reflexivity gl = - setoid_proof gl "reflexive" reflexive_proof_global (reflexivity_red true) - -let setoid_symmetry gl = - setoid_proof gl "symmetric" symmetric_proof_global (symmetry_red true) - -let setoid_transitivity c gl = - let binding_name = - next_ident_away (id_of_string "y") (ids_of_named_context (named_context (pf_env gl))) - in - setoid_proof gl "transitive" - ~bindings:(Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp binding_name, constrIn c ]) - transitive_proof_global (transitivity_red true c) -*) -let setoid_symmetry_in id gl = - let ctype = pf_type_of gl (mkVar id) in - let binders,concl = Sign.decompose_prod_assum ctype in - let (equiv, args) = decompose_app concl 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 equivalence." - in - let others,(c1,c2) = split_last_two args in - let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in - let new_hyp' = mkApp (he, [| c2 ; c1 |]) in - let new_hyp = it_mkProd_or_LetIn new_hyp' binders in - tclTHENS (cut new_hyp) - [ intro_replacing id; - tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ] ] - gl - -let _ = Tactics.register_setoid_reflexivity setoid_reflexivity -let _ = Tactics.register_setoid_symmetry setoid_symmetry -let _ = Tactics.register_setoid_symmetry_in setoid_symmetry_in -let _ = Tactics.register_setoid_transitivity setoid_transitivity - -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 t ] -END +(** 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 + | 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 @@ -1836,101 +745,23 @@ TACTIC EXTEND head_of_constr ] END - -let coq_List_nth = lazy (gen_constant ["Lists"; "List"] "nth") -let coq_List_cons = lazy (gen_constant ["Lists"; "List"] "cons") -let coq_List_nil = lazy (gen_constant ["Lists"; "List"] "nil") - -let freevars c = - let rec frec acc c = match kind_of_term c with - | Var id -> Idset.add id acc - | _ -> fold_constr frec acc c - in - frec Idset.empty c - -let coq_zero = lazy (gen_constant ["Init"; "Datatypes"] "O") -let coq_succ = lazy (gen_constant ["Init"; "Datatypes"] "S") -let coq_nat = lazy (gen_constant ["Init"; "Datatypes"] "nat") - -let rec coq_nat_of_int = function - | 0 -> Lazy.force coq_zero - | n -> mkApp (Lazy.force coq_succ, [| coq_nat_of_int (pred n) |]) - -let varify_constr_list ty def varh c = - let vars = Idset.elements (freevars c) in - let mkaccess i = - mkApp (Lazy.force coq_List_nth, - [| ty; coq_nat_of_int i; varh; def |]) - in - let l = List.fold_right (fun id acc -> - mkApp (Lazy.force coq_List_cons, [| ty ; mkVar id; acc |])) - vars (mkApp (Lazy.force coq_List_nil, [| ty |])) - in - let subst = - list_map_i (fun i id -> (id, mkaccess i)) 0 vars - in - l, replace_vars subst c - -let coq_varmap_empty = lazy (gen_constant ["ring"; "Quote"] "Empty_vm") -let coq_varmap_node = lazy (gen_constant ["ring"; "Quote"] "Node_vm") -(* | Node_vm : A -> varmap -> varmap -> varmap. *) - -let coq_varmap_lookup = lazy (gen_constant ["ring"; "Quote"] "varmap_find") - -let coq_index_left = lazy (gen_constant ["ring"; "Quote"] "Left_idx") -let coq_index_right = lazy (gen_constant ["ring"; "Quote"] "Right_idx") -let coq_index_end = lazy (gen_constant ["ring"; "Quote"] "End_idx") - -let rec split_interleaved l r = function - | hd :: hd' :: tl' -> - split_interleaved (hd :: l) (hd' :: r) tl' - | hd :: [] -> (List.rev (hd :: l), List.rev r) - | [] -> (List.rev l, List.rev r) - -(* let rec mkidx i acc = *) -(* if i mod 2 = 0 then *) -(* let acc' = mkApp (Lazy.force coq_index_left, [|acc|]) in *) -(* if i = 0 then acc' *) -(* else mkidx (i / 2) acc' *) -(* else *) -(* let acc' = mkApp (Lazy.force coq_index_right, [|acc|]) in *) -(* if i = 1 then acc' *) -(* else mkidx (i / 2) acc' *) - -let rec mkidx i p = - if i mod 2 = 0 then - if i = 0 then mkApp (Lazy.force coq_index_left, [|Lazy.force coq_index_end|]) - else mkApp (Lazy.force coq_index_left, [|mkidx (i - p) (2 * p)|]) - else if i = 1 then mkApp (Lazy.force coq_index_right, [|Lazy.force coq_index_end|]) - else mkApp (Lazy.force coq_index_right, [|mkidx (i - p) (2 * p)|]) - -let varify_constr_varmap ty def varh c = - let vars = Idset.elements (freevars c) in - let mkaccess i = - mkApp (Lazy.force coq_varmap_lookup, - [| ty; def; i; varh |]) - in - let rec vmap_aux l cont = - match l with - | [] -> [], mkApp (Lazy.force coq_varmap_empty, [| ty |]) - | hd :: tl -> - let left, right = split_interleaved [] [] tl in - let leftvars, leftmap = vmap_aux left (fun x -> cont (mkApp (Lazy.force coq_index_left, [| x |]))) in - let rightvars, rightmap = vmap_aux right (fun x -> cont (mkApp (Lazy.force coq_index_right, [| x |]))) in - (hd, cont (Lazy.force coq_index_end)) :: leftvars @ rightvars, - mkApp (Lazy.force coq_varmap_node, [| ty; hd; leftmap ; rightmap |]) - in - let subst, vmap = vmap_aux (def :: List.map (fun x -> mkVar x) vars) (fun x -> x) in - let subst = List.map (fun (id, x) -> (destVar id, mkaccess x)) (List.tl subst) in - vmap, replace_vars subst c - - -TACTIC EXTEND varify - [ "varify" ident(varh) ident(h') constr(ty) constr(def) constr(c) ] -> [ - let vars, c' = varify_constr_varmap ty def (mkVar varh) c in - tclTHEN (letin_tac None (Name varh) vars None allHyps) - (letin_tac None (Name h') c' None allHyps) - ] +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/contradiction.ml b/tactics/contradiction.ml index 313d74a1..46ed2134 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: contradiction.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id$ *) open Util open Term @@ -27,9 +27,9 @@ let absurd c gls = (Evd.create_goal_evar_defs sigma) (Retyping.get_judgment_of env sigma c) in let c = j.Environ.utj_val in (tclTHENS - (tclTHEN (elim_type (build_coq_False ())) (cut c)) + (tclTHEN (elim_type (build_coq_False ())) (cut c)) ([(tclTHENS - (cut (applist(build_coq_not (),[c]))) + (cut (applist(build_coq_not (),[c]))) ([(tclTHEN intros ((fun gl -> let ida = pf_nth_hyp_id gl 1 @@ -59,7 +59,7 @@ let contradiction_context gl = 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) + 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) diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli index e417f500..9c38362a 100644 --- a/tactics/contradiction.mli +++ b/tactics/contradiction.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: contradiction.mli 9842 2007-05-20 17:44:23Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names @@ -17,4 +17,4 @@ open Genarg (*i*) val absurd : constr -> tactic -val contradiction : constr with_ebindings option -> tactic +val contradiction : constr with_bindings option -> tactic diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml index 62824670..2b583af4 100644 --- a/tactics/decl_interp.ml +++ b/tactics/decl_interp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: decl_interp.ml 12422 2009-10-27 08:42:49Z corbinea $ i*) +(*i $Id$ i*) open Util open Names @@ -22,18 +22,18 @@ open Pp (* INTERN *) -let raw_app (loc,hd,args) = if args =[] then hd else RApp(loc,hd,args) +let raw_app (loc,hd,args) = if args =[] then hd else RApp(loc,hd,args) -let intern_justification_items globs = +let intern_justification_items globs = Option.map (List.map (intern_constr globs)) -let intern_justification_method globs = +let intern_justification_method globs = Option.map (intern_tactic globs) let intern_statement intern_it globs st = {st_label=st.st_label; st_it=intern_it globs st.st_it} - + let intern_no_bind intern_it globs x = globs,intern_it globs x @@ -41,22 +41,22 @@ let intern_constr_or_thesis globs = function Thesis n -> Thesis n | This c -> This (intern_constr globs c) -let add_var id globs= +let add_var id globs= let l1,l2=globs.ltacvars in {globs with ltacvars= (id::l1),(id::l2)} let add_name nam globs= - match nam with + match nam with Anonymous -> globs | Name id -> add_var id globs -let intern_hyp iconstr globs = function +let intern_hyp iconstr globs = function Hvar (loc,(id,topt)) -> add_var id globs, Hvar (loc,(id,Option.map (intern_constr globs) topt)) | Hprop st -> add_name st.st_label globs, Hprop (intern_statement iconstr globs st) -let intern_hyps iconstr globs hyps = +let intern_hyps iconstr globs hyps = snd (list_fold_map (intern_hyp iconstr) globs hyps) let intern_cut intern_it globs cut= @@ -65,32 +65,32 @@ let intern_cut intern_it globs cut= cut_by=intern_justification_items nglobs cut.cut_by; cut_using=intern_justification_method nglobs cut.cut_using} -let intern_casee globs = function +let intern_casee globs = function Real c -> Real (intern_constr globs c) - | Virtual cut -> Virtual - (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) + | Virtual cut -> Virtual + (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) let intern_hyp_list args globs = let intern_one globs (loc,(id,opttyp)) = (add_var id globs), (loc,(id,Option.map (intern_constr globs) opttyp)) in - list_fold_map intern_one globs args + list_fold_map intern_one globs args -let intern_suffices_clause globs (hyps,c) = +let intern_suffices_clause globs (hyps,c) = let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in - nglobs,(nhyps,intern_constr_or_thesis nglobs c) + nglobs,(nhyps,intern_constr_or_thesis nglobs c) -let intern_fundecl args body globs= +let intern_fundecl args body globs= let nglobs,nargs = intern_hyp_list args globs in nargs,intern_constr nglobs body - + let rec add_vars_of_simple_pattern globs = function CPatAlias (loc,p,id) -> add_vars_of_simple_pattern (add_var id globs) p -(* Stdpp.raise_with_loc loc +(* Stdpp.raise_with_loc loc (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) | CPatOr (loc, _)-> - Stdpp.raise_with_loc loc + Stdpp.raise_with_loc loc (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) | CPatDelimiters (_,_,p) -> add_vars_of_simple_pattern globs p @@ -99,26 +99,26 @@ let rec add_vars_of_simple_pattern globs = function | CPatNotation(_,_,(pl,pll)) -> List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll)) | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs - | _ -> globs + | _ -> globs let rec intern_bare_proof_instr globs = function Pthus i -> Pthus (intern_bare_proof_instr globs i) | Pthen i -> Pthen (intern_bare_proof_instr globs i) | Phence i -> Phence (intern_bare_proof_instr globs i) - | Pcut c -> Pcut - (intern_cut + | Pcut c -> Pcut + (intern_cut (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c) - | Psuffices c -> + | Psuffices c -> Psuffices (intern_cut intern_suffices_clause globs c) - | Prew (s,c) -> Prew - (s,intern_cut - (intern_no_bind (intern_statement intern_constr)) globs c) + | Prew (s,c) -> Prew + (s,intern_cut + (intern_no_bind (intern_statement intern_constr)) globs c) | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps) - | Pcase (params,pat,hyps) -> + | Pcase (params,pat,hyps) -> let nglobs,nparams = intern_hyp_list params globs in let nnglobs= add_vars_of_simple_pattern nglobs pat in let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in - Pcase (nparams,pat,nhyps) + Pcase (nparams,pat,nhyps) | Ptake witl -> Ptake (List.map (intern_constr globs) witl) | Pconsider (c,hyps) -> Pconsider (intern_constr globs c, intern_hyps intern_constr globs hyps) @@ -130,7 +130,7 @@ let rec intern_bare_proof_instr globs = function | Plet hyps -> Plet (intern_hyps intern_constr globs hyps) | Pclaim st -> Pclaim (intern_statement intern_constr globs st) | Pfocus st -> Pfocus (intern_statement intern_constr globs st) - | Pdefine (id,args,body) -> + | Pdefine (id,args,body) -> let nargs,nbody = intern_fundecl args body globs in Pdefine (id,nargs,nbody) | Pcast (id,typ) -> @@ -145,10 +145,10 @@ let rec intern_proof_instr globs instr= let interp_justification_items sigma env = Option.map (List.map (fun c ->understand sigma env (fst c))) -let interp_constr check_sort sigma env c = - if check_sort then - understand_type sigma env (fst c) - else +let interp_constr check_sort sigma env c = + if check_sort then + understand_type sigma env (fst c) + else understand sigma env (fst c) let special_whd env = @@ -162,13 +162,13 @@ let decompose_eq env id = let whd = special_whd env typ in match kind_of_term whd with App (f,args)-> - if eq_constr f _eq && (Array.length args)=3 + if eq_constr f _eq && (Array.length args)=3 then args.(0) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." let get_eq_typ info env = - let typ = decompose_eq env (get_last env) in + let typ = decompose_eq env (get_last env) in typ let interp_constr_in_type typ sigma env c = @@ -177,33 +177,28 @@ let interp_constr_in_type typ sigma env c = let interp_statement interp_it sigma env st = {st_label=st.st_label; st_it=interp_it sigma env st.st_it} - + let interp_constr_or_thesis check_sort sigma env = function Thesis n -> Thesis n | This c -> This (interp_constr check_sort sigma env c) -let type_tester_var body typ = - raw_app(dummy_loc, - RLambda(dummy_loc,Anonymous,Explicit,typ, - RSort (dummy_loc,RProp Null)),body) - -let abstract_one_hyp inject h raw = - match h with - Hvar (loc,(id,None)) -> +let abstract_one_hyp inject h raw = + match h with + Hvar (loc,(id,None)) -> RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw) - | Hvar (loc,(id,Some typ)) -> + | Hvar (loc,(id,Some typ)) -> RProd (dummy_loc,Name id, Explicit, fst typ, raw) - | Hprop st -> + | Hprop st -> RProd (dummy_loc,st.st_label, Explicit, inject st.st_it, raw) -let rawconstr_of_hyps inject hyps head = +let rawconstr_of_hyps inject hyps head = List.fold_right (abstract_one_hyp inject) hyps head let raw_prop = RSort (dummy_loc,RProp Null) - -let rec match_hyps blend names constr = function + +let rec match_hyps blend names constr = function [] -> [],substl names constr - | hyp::q -> + | hyp::q -> let (name,typ,body)=destProd constr in let st= {st_label=name;st_it=substl names typ} in let qnames= @@ -216,7 +211,7 @@ let rec match_hyps blend names constr = function let rhyps,head = match_hyps blend qnames body q in qhyp::rhyps,head -let interp_hyps_gen inject blend sigma env hyps head = +let interp_hyps_gen inject blend sigma env hyps head = let constr=understand sigma env (rawconstr_of_hyps inject hyps head) in match_hyps blend [] constr hyps @@ -224,42 +219,42 @@ let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma e let dummy_prefix= id_of_string "__" -let rec deanonymize ids = - function - PatVar (loc,Anonymous) -> +let rec deanonymize ids = + function + PatVar (loc,Anonymous) -> let (found,known) = !ids in - let new_id=Nameops.next_ident_away dummy_prefix known in + let new_id=Namegen.next_ident_away dummy_prefix known in let _= ids:= (loc,new_id) :: found , new_id :: known in PatVar (loc,Name new_id) - | PatVar (loc,Name id) as pat -> + | PatVar (loc,Name id) as pat -> let (found,known) = !ids in let _= ids:= (loc,id) :: found , known in pat - | PatCstr(loc,cstr,lpat,nam) -> + | PatCstr(loc,cstr,lpat,nam) -> PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam) let rec raw_of_pat = - function - PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" - | PatVar (loc,Name id) -> + function + PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" + | PatVar (loc,Name id) -> RVar (loc,id) - | PatCstr(loc,((ind,_) as cstr),lpat,_) -> + | PatCstr(loc,((ind,_) as cstr),lpat,_) -> let mind= fst (Global.lookup_inductive ind) in let rec add_params n q = if n<=0 then q else add_params (pred n) (RHole(dummy_loc, Evd.TomatchTypeParameter(ind,n))::q) in - let args = List.map raw_of_pat lpat in + let args = List.map raw_of_pat lpat in raw_app(loc,RRef(dummy_loc,Libnames.ConstructRef cstr), - add_params mind.Declarations.mind_nparams args) - + add_params mind.Declarations.mind_nparams args) + let prod_one_hyp = function (loc,(id,None)) -> - (fun raw -> + (fun raw -> RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw)) - | (loc,(id,Some typ)) -> - (fun raw -> + | (loc,(id,Some typ)) -> + (fun raw -> RProd (dummy_loc,Name id, Explicit, fst typ, raw)) let prod_one_id (loc,id) raw = @@ -270,13 +265,13 @@ let let_in_one_alias (id,pat) raw = RLetIn (dummy_loc,Name id, raw_of_pat pat, raw) let rec bind_primary_aliases map pat = - match pat with + match pat with PatVar (_,_) -> map | PatCstr(loc,_,lpat,nam) -> let map1 = - match nam with + match nam with Anonymous -> map - | Name id -> (id,pat)::map + | Name id -> (id,pat)::map in List.fold_left bind_primary_aliases map1 lpat @@ -288,17 +283,17 @@ let bind_aliases patvars subst patt = let map1 = bind_secondary_aliases map subst in List.rev map1 -let interp_pattern env pat_expr = +let interp_pattern env pat_expr = let patvars,pats = Constrintern.intern_pattern env pat_expr in - match pats with + match pats with [] -> anomaly "empty pattern list" | [subst,patt] -> (patvars,bind_aliases patvars subst patt,patt) | _ -> anomaly "undetected disjunctive pattern" -let rec match_args dest names constr = function +let rec match_args dest names constr = function [] -> [],names,substl names constr - | _::q -> + | _::q -> let (name,typ,body)=dest constr in let st={st_label=name;st_it=substl names typ} in let qnames= @@ -308,9 +303,9 @@ let rec match_args dest names constr = function let args,bnames,body = match_args dest qnames body q in st::args,bnames,body -let rec match_aliases names constr = function +let rec match_aliases names constr = function [] -> [],names,substl names constr - | _::q -> + | _::q -> let (name,c,typ,body)=destLetIn constr in let st={st_label=name;st_it=(substl names c,substl names typ)} in let qnames= @@ -329,7 +324,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = | _ -> error "No proof per cases/induction/inversion in progress." in let mib,oib=Global.lookup_inductive pinfo.per_ind in let num_params = pinfo.per_nparams in - let _ = + let _ = let expected = mib.Declarations.mind_nparams - num_params in if List.length params <> expected then errorlabstrm "suppose it is" @@ -338,12 +333,12 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = str "expected.") in let app_ind = let rind = RRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in - let rparams = List.map detype_ground pinfo.per_params in - let rparams_rec = - List.map - (fun (loc,(id,_)) -> - RVar (loc,id)) params in - let dum_args= + let rparams = List.map detype_ground pinfo.per_params in + let rparams_rec = + List.map + (fun (loc,(id,_)) -> + RVar (loc,id)) params in + let dum_args= list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false))) oib.Declarations.mind_nrealargs in raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in @@ -351,22 +346,22 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let inject = function Thesis (Plain) -> Rawterm.RSort(dummy_loc,RProp Null) | Thesis (For rec_occ) -> - if not (List.mem rec_occ pat_vars) then - errorlabstrm "suppose it is" - (str "Variable " ++ Nameops.pr_id rec_occ ++ + if not (List.mem rec_occ pat_vars) then + errorlabstrm "suppose it is" + (str "Variable " ++ Nameops.pr_id rec_occ ++ str " does not occur in pattern."); Rawterm.RSort(dummy_loc,RProp Null) | This (c,_) -> c in let term1 = rawconstr_of_hyps inject hyps raw_prop in let loc_ids,npatt = let rids=ref ([],pat_vars) in - let npatt= deanonymize rids patt in + let npatt= deanonymize rids patt in List.rev (fst !rids),npatt in let term2 = RLetIn(dummy_loc,Anonymous, RCast(dummy_loc,raw_of_pat npatt, CastConv (DEFAULTcast,app_ind)),term1) in - let term3=List.fold_right let_in_one_alias aliases term2 in + let term3=List.fold_right let_in_one_alias aliases term2 in let term4=List.fold_right prod_one_id loc_ids term3 in let term5=List.fold_right prod_one_hyp params term4 in let constr = understand sigma env term5 in @@ -375,8 +370,8 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in let blend st st' = - match st'.st_it with - Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} + match st'.st_it with + Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} | This _ -> {st_it = This st.st_it;st_label=st.st_label} in let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in tparams,{pat_vars=tpatvars; @@ -388,7 +383,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let interp_cut interp_it sigma env cut= let nenv,nstat = interp_it sigma env cut.cut_stat in - {cut with + {cut with cut_stat=nstat; cut_by=interp_justification_items sigma nenv cut.cut_by} @@ -398,7 +393,7 @@ let interp_no_bind interp_it sigma env x = let interp_suffices_clause sigma env (hyps,cot)= let (locvars,_) as res = match cot with - This (c,_) -> + This (c,_) -> let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in nhyps,This nc | Thesis Plain as th -> interp_hyps sigma env hyps,th @@ -409,26 +404,26 @@ let interp_suffices_clause sigma env (hyps,cot)= match st.st_label with Name id -> Environ.push_named (id,None,st.st_it) env0 | _ -> env in - let nenv = List.fold_right push_one locvars env in - nenv,res - -let interp_casee sigma env = function + let nenv = List.fold_right push_one locvars env in + nenv,res + +let interp_casee sigma env = function Real c -> Real (understand sigma env (fst c)) - | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) + | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) let abstract_one_arg = function (loc,(id,None)) -> - (fun raw -> - RLambda (dummy_loc,Name id, Explicit, + (fun raw -> + RLambda (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw)) - | (loc,(id,Some typ)) -> - (fun raw -> + | (loc,(id,Some typ)) -> + (fun raw -> RLambda (dummy_loc,Name id, Explicit, fst typ, raw)) -let rawconstr_of_fun args body = +let rawconstr_of_fun args body = List.fold_right abstract_one_arg args (fst body) -let interp_fun sigma env args body = +let interp_fun sigma env args body = let constr=understand sigma env (rawconstr_of_fun args body) in match_args destLambda [] constr args @@ -436,22 +431,22 @@ let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = fu Pthus i -> Pthus (interp_bare_proof_instr info sigma env i) | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i) | Phence i -> Phence (interp_bare_proof_instr info sigma env i) - | Pcut c -> Pcut (interp_cut - (interp_no_bind (interp_statement - (interp_constr_or_thesis true))) - sigma env c) - | Psuffices c -> + | Pcut c -> Pcut (interp_cut + (interp_no_bind (interp_statement + (interp_constr_or_thesis true))) + sigma env c) + | Psuffices c -> Psuffices (interp_cut interp_suffices_clause sigma env c) - | Prew (s,c) -> Prew (s,interp_cut - (interp_no_bind (interp_statement + | Prew (s,c) -> Prew (s,interp_cut + (interp_no_bind (interp_statement (interp_constr_in_type (get_eq_typ info env)))) - sigma env c) + sigma env c) | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps) - | Pcase (params,pat,hyps) -> - let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in + | Pcase (params,pat,hyps) -> + let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in Pcase (tparams,tpat,thyps) - | Ptake witl -> + | Ptake witl -> Ptake (List.map (fun c -> understand sigma env (fst c)) witl) | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c, interp_hyps sigma env hyps) @@ -463,15 +458,15 @@ let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = fu | Plet hyps -> Plet (interp_hyps sigma env hyps) | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st) | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st) - | Pdefine (id,args,body) -> + | Pdefine (id,args,body) -> let nargs,_,nbody = interp_fun sigma env args body in Pdefine (id,nargs,nbody) - | Pcast (id,typ) -> + | Pcast (id,typ) -> Pcast(id,interp_constr true sigma env typ) let rec interp_proof_instr info sigma env instr= {emph = instr.emph; instr = interp_bare_proof_instr info sigma env instr.instr} - + diff --git a/tactics/decl_interp.mli b/tactics/decl_interp.mli index 59b3b530..bd085938 100644 --- a/tactics/decl_interp.mli +++ b/tactics/decl_interp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: decl_interp.mli 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id$ *) open Tacinterp open Decl_expr diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml index 67d1d41a..9c58f06e 100644 --- a/tactics/decl_proof_instr.ml +++ b/tactics/decl_proof_instr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: decl_proof_instr.ml 12422 2009-10-27 08:42:49Z corbinea $ *) +(* $Id$ *) open Util open Pp @@ -28,6 +28,7 @@ open Tactics open Tacticals open Term open Termops +open Namegen open Reductionops open Goptions @@ -36,27 +37,27 @@ open Goptions let get_its_info gls = get_info gls.it -let get_strictness,set_strictness = +let get_strictness,set_strictness = let strictness = ref false in (fun () -> (!strictness)),(fun b -> strictness:=b) let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "strict mode"; - optkey = (SecondaryTable ("Strict","Proofs")); + optkey = ["Strict";"Proofs"]; optread = get_strictness; optwrite = set_strictness } -let tcl_change_info_gen info_gen = +let tcl_change_info_gen info_gen = (fun gls -> - let gl =sig_it gls in - {it=[{gl with evar_extra=info_gen}];sigma=sig_sig gls}, - function + let gl =sig_it gls in + {it=[{gl with evar_extra=info_gen}];sigma=sig_sig gls}, + function [pftree] -> {pftree with goal=gl; - ref=Some (Prim Change_evars,[pftree])} + ref=Some (Prim Change_evars,[pftree])} | _ -> anomaly "change_info : Wrong number of subtrees") let tcl_change_info info gls = tcl_change_info_gen (Some (pm_in info)) gls @@ -78,27 +79,27 @@ let is_good_inductive env ind = let check_not_per pts = if not (Proof_trees.is_complete_proof (proof_of_pftreestate pts)) then match get_stack pts with - Per (_,_,_,_)::_ -> + Per (_,_,_,_)::_ -> error "You are inside a proof per cases/induction.\n\ Please \"suppose\" something or \"end\" it now." | _ -> () let mk_evd metalist gls = let evd0= create_goal_evar_defs (sig_sig gls) in - let add_one (meta,typ) evd = + let add_one (meta,typ) evd = meta_declare meta typ evd in List.fold_right add_one metalist evd0 -let is_tmp id = (string_of_id id).[0] = '_' +let is_tmp id = (string_of_id id).[0] = '_' -let tmp_ids gls = +let tmp_ids gls = let ctx = pf_hyps gls in - match ctx with + match ctx with [] -> [] - | _::q -> List.filter is_tmp (ids_of_named_context q) + | _::q -> List.filter is_tmp (ids_of_named_context q) -let clean_tmp gls = - let clean_id id0 gls0 = +let clean_tmp gls = + let clean_id id0 gls0 = tclTRY (clear [id0]) gls0 in let rec clean_all = function [] -> tclIDTAC @@ -114,30 +115,30 @@ let assert_postpone id t = let start_proof_tac gls= let gl=sig_it gls in let info={pm_stack=[]} in - {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls}, - function + {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls}, + function [pftree] -> {pftree with goal=gl; - ref=Some (Decl_proof true,[pftree])} + ref=Some (Decl_proof true,[pftree])} | _ -> anomaly "Dem : Wrong number of subtrees" -let go_to_proof_mode () = - Pfedit.mutate +let go_to_proof_mode () = + Pfedit.mutate (fun pts -> nth_unproven 1 (solve_pftreestate start_proof_tac pts)) (* closing gaps *) let daimon_tac gls = set_daimon_flag (); - ({it=[];sigma=sig_sig gls}, - function + ({it=[];sigma=sig_sig gls}, + function [] -> {open_subgoals=0; goal=sig_it gls; - ref=Some (Daimon,[])} + ref=Some (Daimon,[])} | _ -> anomaly "Daimon: Wrong number of subtrees") - + let daimon _ pftree = set_daimon_flag (); {pftree with @@ -150,7 +151,7 @@ let daimon_subtree = map_pftreestate (fun _ -> frontier_mapi daimon ) let rec is_focussing_instr = function Pthus i | Pthen i | Phence i -> is_focussing_instr i - | Pescape | Pper _ | Pclaim _ | Pfocus _ + | Pescape | Pper _ | Pclaim _ | Pfocus _ | Psuppose _ | Pcase (_,_,_) -> true | _ -> false @@ -158,7 +159,7 @@ let mark_rule_as_done = function Decl_proof true -> Decl_proof false | Decl_proof false -> anomaly "already marked as done" - | Nested(Proof_instr (lock_focus,instr),spfl) -> + | Nested(Proof_instr (lock_focus,instr),spfl) -> if lock_focus then Nested(Proof_instr (false,instr),spfl) else @@ -168,34 +169,34 @@ let mark_rule_as_done = function let mark_proof_tree_as_done pt = match pt.ref with None -> anomaly "mark_proof_tree_as_done" - | Some (r,spfl) -> + | Some (r,spfl) -> {pt with ref= Some (mark_rule_as_done r,spfl)} -let mark_as_done pts = - map_pftreestate - (fun _ -> mark_proof_tree_as_done) - (up_to_matching_rule is_focussing_command pts) +let mark_as_done pts = + map_pftreestate + (fun _ -> mark_proof_tree_as_done) + (up_to_matching_rule is_focussing_command pts) (* post-instruction focus management *) let goto_current_focus pts = up_until_matching_rule is_focussing_command pts -let goto_current_focus_or_top pts = - try +let goto_current_focus_or_top pts = + try up_until_matching_rule is_focussing_command pts with Not_found -> top_of_tree pts (* return *) let close_tactic_mode pts = - let pts1= - try goto_current_focus pts - with Not_found -> + let pts1= + try goto_current_focus pts + with Not_found -> error "\"return\" cannot be used outside of Declarative Proof Mode." in let pts2 = daimon_subtree pts1 in - let pts3 = mark_as_done pts2 in - goto_current_focus pts3 - + let pts3 = mark_as_done pts2 in + goto_current_focus pts3 + let return_from_tactic_mode () = Pfedit.mutate close_tactic_mode (* end proof/claim *) @@ -207,11 +208,11 @@ let close_block bt pts = else get_stack pts in match bt,stack with - B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> + B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> daimon_subtree (goto_current_focus pts) - | _, Claim::_ -> + | _, Claim::_ -> error "\"end claim\" expected." - | _, Focus_claim::_ -> + | _, Focus_claim::_ -> error "\"end focus\" expected." | _, [] -> error "\"end proof\" expected." @@ -225,18 +226,18 @@ let close_block bt pts = (* utility for suppose / suppose it is *) -let close_previous_case pts = - if - Proof_trees.is_complete_proof (proof_of_pftreestate pts) +let close_previous_case pts = + if + Proof_trees.is_complete_proof (proof_of_pftreestate pts) then match get_top_stack pts with - Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..." - | Suppose_case :: Per (et,_,_,_) :: _ -> + Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..." + | Suppose_case :: Per (et,_,_,_) :: _ -> goto_current_focus (mark_as_done pts) - | _ -> error "Not inside a proof per cases or induction." + | _ -> error "Not inside a proof per cases or induction." else match get_stack pts with - Per (et,_,_,_) :: _ -> pts + Per (et,_,_,_) :: _ -> pts | Suppose_case :: Per (et,_,_,_) :: _ -> goto_current_focus (mark_as_done (daimon_subtree pts)) | _ -> error "Not inside a proof per cases or induction." @@ -246,10 +247,10 @@ let close_previous_case pts = (* automation *) let filter_hyps f gls = - let filter_aux (id,_,_) = - if f id then + let filter_aux (id,_,_) = + if f id then tclIDTAC - else + else tclTRY (clear [id]) in tclMAP filter_aux (Environ.named_context_of_val gls.it.evar_hyps) gls @@ -257,16 +258,16 @@ let local_hyp_prefix = id_of_string "___" let add_justification_hyps keep items gls = let add_aux c gls= - match kind_of_term c with - Var id -> + match kind_of_term c with + Var id -> keep:=Idset.add id !keep; - tclIDTAC gls - | _ -> - let id=pf_get_new_id local_hyp_prefix gls in - keep:=Idset.add id !keep; + tclIDTAC gls + | _ -> + let id=pf_get_new_id local_hyp_prefix gls in + keep:=Idset.add id !keep; tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere) - (thin_body [id]) gls in - tclMAP add_aux items gls + (thin_body [id]) gls in + tclMAP add_aux items gls let prepare_goal items gls = let tokeep = ref Idset.empty in @@ -275,18 +276,18 @@ let prepare_goal items gls = [ (fun _ -> auxres); filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls -let my_automation_tac = ref +let my_automation_tac = ref (fun gls -> anomaly "No automation registered") let register_automation_tac tac = my_automation_tac:= tac let automation_tac gls = !my_automation_tac gls -let justification tac gls= - tclORELSE - (tclSOLVE [tclTHEN tac assumption]) - (fun gls -> - if get_strictness () then +let justification tac gls= + tclORELSE + (tclSOLVE [tclTHEN tac assumption]) + (fun gls -> + if get_strictness () then error "Insufficient justification." else begin @@ -326,7 +327,7 @@ type stackd_elt = se_type:types; se_last_meta:metavariable; se_meta_list:(metavariable*types) list; - se_evd: evar_defs} + se_evd: evar_map} let rec replace_in_list m l = function [] -> raise Not_found @@ -340,44 +341,44 @@ let enstack_subsubgoals env se stack gls= Inductive.lookup_mind_specif env ind in let gentypes= Inductive.arities_of_constructors ind (mib,oib) in - let process i gentyp = - let constructor = mkConstruct(ind,succ i) + let process i gentyp = + let constructor = mkConstruct(ind,succ i) (* constructors numbering*) in let appterm = applist (constructor,params) in let apptype = Term.prod_applist gentyp params in let rc,_ = Reduction.dest_prod env apptype in - let rec meta_aux last lenv = function + let rec meta_aux last lenv = function [] -> (last,lenv,[]) | (nam,_,typ)::q -> let nlast=succ last in let (llast,holes,metas) = meta_aux nlast (mkMeta nlast :: lenv) q in (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in - let (nlast,holes,nmetas) = + let (nlast,holes,nmetas) = meta_aux se.se_last_meta [] (List.rev rc) in let refiner = applist (appterm,List.rev holes) in - let evd = meta_assign se.se_meta + let evd = meta_assign se.se_meta (refiner,(ConvUpToEta 0,TypeProcessed (* ? *))) se.se_evd in - let ncreated = replace_in_list + let ncreated = replace_in_list se.se_meta nmetas se.se_meta_list in - let evd0 = List.fold_left - (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in - List.iter (fun (m,typ) -> - Stack.push + let evd0 = List.fold_left + (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in + List.iter (fun (m,typ) -> + Stack.push {se_meta=m; se_type=typ; se_evd=evd0; se_meta_list=ncreated; - se_last_meta=nlast} stack) (List.rev nmetas) + se_last_meta=nlast} stack) (List.rev nmetas) in Array.iteri process gentypes | _ -> () -let rec nf_list evd = +let rec nf_list evd = function - [] -> [] - | (m,typ)::others -> - if meta_defined evd m then + [] -> [] + | (m,typ)::others -> + if meta_defined evd m then nf_list evd others else (m,nf_meta evd typ)::nf_list evd others @@ -387,29 +388,29 @@ let find_subsubgoal c ctyp skip submetas gls = let concl = pf_concl gls in let evd = mk_evd ((0,concl)::submetas) gls in let stack = Stack.create () in - let max_meta = + let max_meta = List.fold_left (fun a (m,_) -> max a m) 0 submetas in - let _ = Stack.push + let _ = Stack.push {se_meta=0; se_type=concl; se_last_meta=max_meta; se_meta_list=[0,concl]; se_evd=evd} stack in - let rec dfs n = + let rec dfs n = let se = Stack.pop stack in - try - let unifier = - Unification.w_unify true env Reduction.CUMUL + try + let unifier = + Unification.w_unify true env Reduction.CUMUL ctyp se.se_type se.se_evd in - if n <= 0 then - {se with + if n <= 0 then + {se with se_evd=meta_assign se.se_meta (c,(ConvUpToEta 0,TypeNotProcessed (* ?? *))) unifier; - se_meta_list=replace_in_list + se_meta_list=replace_in_list se.se_meta submetas se.se_meta_list} else dfs (pred n) - with _ -> + with _ -> begin enstack_subsubgoals env se stack gls; dfs n @@ -421,20 +422,20 @@ let concl_refiner metas body gls = let concl = pf_concl gls in let evd = sig_sig gls in let env = pf_env gls in - let sort = family_of_sort (Typing.sort_of env evd concl) in + let sort = family_of_sort (Typing.sort_of env evd concl) in let rec aux env avoid subst = function [] -> anomaly "concl_refiner: cannot happen" | (n,typ)::rest -> - let _A = subst_meta subst typ in - let x = id_of_name_using_hdchar env _A Anonymous in + let _A = subst_meta subst typ in + let x = id_of_name_using_hdchar env _A Anonymous in let _x = fresh_id avoid x gls in let nenv = Environ.push_named (_x,None,_A) env in let asort = family_of_sort (Typing.sort_of nenv evd _A) in let nsubst = (n,mkVar _x)::subst in - if rest = [] then + if rest = [] then asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) else - let bsort,_B,nbody = + let bsort,_B,nbody = aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in let body = mkNamedLambda _x _A nbody in if occur_term (mkVar _x) _B then @@ -450,7 +451,7 @@ let concl_refiner metas body gls = let _P0 = mkLambda(Anonymous,_AxB,concl) in InType,_AxB, mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|]) - | _,_ -> + | _,_ -> let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in let _P0 = mkLambda(Anonymous,_AxB,concl) in InType,_AxB, @@ -473,26 +474,23 @@ let concl_refiner metas body gls = let (_,_,prf) = aux env [] [] metas in mkApp(prf,[|mkMeta 1|]) -let thus_tac c ctyp submetas gls = - let list,proof = +let thus_tac c ctyp submetas gls = + let list,proof = try find_subsubgoal c ctyp 0 submetas gls - with Not_found -> + with Not_found -> error "I could not relate this statement to the thesis." in if list = [] then - exact_check proof gls + exact_check proof gls else let refiner = concl_refiner list proof gls in Tactics.refine refiner gls (* general forward step *) - -let anon_id_base = id_of_string "__" - -let mk_stat_or_thesis info gls = function +let mk_stat_or_thesis info gls = function This c -> c - | Thesis (For _ ) -> + | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> pf_concl gls @@ -500,34 +498,34 @@ let just_tac _then cut info gls0 = let items_tac gls = match cut.cut_by with None -> tclIDTAC gls - | Some items -> - let items_ = - if _then then + | Some items -> + let items_ = + if _then then let last_id = get_last (pf_env gls) in (mkVar last_id)::items - else items + else items in prepare_goal items_ gls in - let method_tac gls = + let method_tac gls = match cut.cut_using with - None -> + None -> automation_tac gls - | Some tac -> + | Some tac -> (Tacinterp.eval_tactic tac) gls in justification (tclTHEN items_tac method_tac) gls0 - -let instr_cut mkstat _thus _then cut gls0 = - let info = get_its_info gls0 in + +let instr_cut mkstat _thus _then cut gls0 = + let info = get_its_info gls0 in let stat = cut.cut_stat in - let (c_id,_) = match stat.st_label with - Anonymous -> - pf_get_new_id (id_of_string "_fact") gls0,false + let (c_id,_) = match stat.st_label with + Anonymous -> + pf_get_new_id (id_of_string "_fact") gls0,false | Name id -> id,true in let c_stat = mkstat info gls0 stat.st_it in - let thus_tac gls= - if _thus then + let thus_tac gls= + if _thus then thus_tac (mkVar c_id) c_stat [] gls else tclIDTAC gls in - tclTHENS (assert_postpone c_id c_stat) + tclTHENS (assert_postpone c_id c_stat) [tclTHEN tcl_erase_info (just_tac _then cut info); thus_tac] gls0 @@ -541,162 +539,162 @@ let decompose_eq id gls = let whd = (special_whd gls typ) in match kind_of_term whd with App (f,args)-> - if eq_constr f _eq && (Array.length args)=3 + if eq_constr f _eq && (Array.length args)=3 then (args.(0), - args.(1), - args.(2)) + args.(1), + args.(2)) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." - -let instr_rew _thus rew_side cut gls0 = - let last_id = + +let instr_rew _thus rew_side cut gls0 = + let last_id = try get_last (pf_env gls0) with _ -> error "No previous equality." in - let typ,lhs,rhs = decompose_eq last_id gls0 in + let typ,lhs,rhs = decompose_eq last_id gls0 in let items_tac gls = match cut.cut_by with None -> tclIDTAC gls | Some items -> prepare_goal items gls in - let method_tac gls = + let method_tac gls = match cut.cut_using with - None -> + None -> automation_tac gls - | Some tac -> + | Some tac -> (Tacinterp.eval_tactic tac) gls in let just_tac gls = justification (tclTHEN items_tac method_tac) gls in - let (c_id,_) = match cut.cut_stat.st_label with - Anonymous -> - pf_get_new_id (id_of_string "_eq") gls0,false + let (c_id,_) = match cut.cut_stat.st_label with + Anonymous -> + pf_get_new_id (id_of_string "_eq") gls0,false | Name id -> id,true in - let thus_tac new_eq gls= - if _thus then + let thus_tac new_eq gls= + if _thus then thus_tac (mkVar c_id) new_eq [] gls else tclIDTAC gls in - match rew_side with + match rew_side with Lhs -> let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in - tclTHENS (assert_postpone c_id new_eq) - [tclTHEN tcl_erase_info - (tclTHENS (transitivity lhs) + tclTHENS (assert_postpone c_id new_eq) + [tclTHEN tcl_erase_info + (tclTHENS (transitivity lhs) [just_tac;exact_check (mkVar last_id)]); thus_tac new_eq] gls0 | Rhs -> let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in - tclTHENS (assert_postpone c_id new_eq) - [tclTHEN tcl_erase_info - (tclTHENS (transitivity rhs) + tclTHENS (assert_postpone c_id new_eq) + [tclTHEN tcl_erase_info + (tclTHENS (transitivity rhs) [exact_check (mkVar last_id);just_tac]); thus_tac new_eq] gls0 - + (* tactics for claim/focus *) -let instr_claim _thus st gls0 = - let info = get_its_info gls0 in - let (id,_) = match st.st_label with - Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false +let instr_claim _thus st gls0 = + let info = get_its_info gls0 in + let (id,_) = match st.st_label with + Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false | Name id -> id,true in - let thus_tac gls= - if _thus then + let thus_tac gls= + if _thus then thus_tac (mkVar id) st.st_it [] gls else tclIDTAC gls in let ninfo1 = {pm_stack= (if _thus then Focus_claim else Claim)::info.pm_stack} in - tclTHENS (assert_postpone id st.st_it) + tclTHENS (assert_postpone id st.st_it) [tcl_change_info ninfo1; thus_tac] gls0 (* tactics for assume *) -let push_intro_tac coerce nam gls = +let push_intro_tac coerce nam gls = let (hid,_) = - match nam with - Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false + match nam with + Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false | Name id -> id,true in - tclTHENLIST + tclTHENLIST [intro_mustbe_force hid; coerce hid] - gls - -let assume_tac hyps gls = - List.fold_right - (fun (Hvar st | Hprop st) -> - tclTHEN - (push_intro_tac - (fun id -> + gls + +let assume_tac hyps gls = + List.fold_right + (fun (Hvar st | Hprop st) -> + tclTHEN + (push_intro_tac + (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) - hyps tclIDTAC gls - -let assume_hyps_or_theses hyps gls = - List.fold_right - (function - (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> - tclTHEN - (push_intro_tac - (fun id -> + hyps tclIDTAC gls + +let assume_hyps_or_theses hyps gls = + List.fold_right + (function + (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> + tclTHEN + (push_intro_tac + (fun id -> convert_hyp (id,None,c)) nam) - | Hprop {st_label=nam;st_it=Thesis (tk)} -> - tclTHEN - (push_intro_tac + | Hprop {st_label=nam;st_it=Thesis (tk)} -> + tclTHEN + (push_intro_tac (fun id -> tclIDTAC) nam)) - hyps tclIDTAC gls + hyps tclIDTAC gls -let assume_st hyps gls = - List.fold_right - (fun st -> - tclTHEN - (push_intro_tac +let assume_st hyps gls = + List.fold_right + (fun st -> + tclTHEN + (push_intro_tac (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) - hyps tclIDTAC gls - -let assume_st_letin hyps gls = - List.fold_right - (fun st -> - tclTHEN - (push_intro_tac - (fun id -> + hyps tclIDTAC gls + +let assume_st_letin hyps gls = + List.fold_right + (fun st -> + tclTHEN + (push_intro_tac + (fun id -> convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label)) - hyps tclIDTAC gls + hyps tclIDTAC gls (* suffices *) -let rec metas_from n hyps = +let rec metas_from n hyps = match hyps with _ :: q -> n :: metas_from (succ n) q | [] -> [] - + let rec build_product args body = - match args with - (Hprop st| Hvar st )::rest -> + match args with + (Hprop st| Hvar st )::rest -> let pprod= lift 1 (build_product rest body) in let lbody = match st.st_label with Anonymous -> pprod | Name id -> subst_term (mkVar id) pprod in mkProd (st.st_label, st.st_it, lbody) - | [] -> body + | [] -> body let rec build_applist prod = function [] -> [],prod - | n::q -> + | n::q -> let (_,typ,_) = destProd prod in let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in (n,typ)::ctx,head -let instr_suffices _then cut gls0 = - let info = get_its_info gls0 in - let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in +let instr_suffices _then cut gls0 = + let info = get_its_info gls0 in + let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in let ctx,hd = cut.cut_stat in let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in let metas = metas_from 1 ctx in let c_ctx,c_head = build_applist c_stat metas in - let c_term = applist (mkVar c_id,List.map mkMeta metas) in - let thus_tac gls= + let c_term = applist (mkVar c_id,List.map mkMeta metas) in + let thus_tac gls= thus_tac c_term c_head c_ctx gls in - tclTHENS (assert_postpone c_id c_stat) - [tclTHENLIST - [ assume_tac ctx; + tclTHENS (assert_postpone c_id c_stat) + [tclTHENLIST + [ assume_tac ctx; tcl_erase_info; just_tac _then cut info]; thus_tac] gls0 @@ -706,7 +704,7 @@ let instr_suffices _then cut gls0 = let conjunction_arity id gls = let typ = pf_get_hyp_typ gls id in let hd,params = decompose_app (special_whd gls typ) in - let env =pf_env gls in + let env =pf_env gls in match kind_of_term hd with Ind ind when is_good_inductive env ind -> let mib,oib= @@ -719,70 +717,70 @@ let conjunction_arity id gls = List.length rc | _ -> raise Not_found -let rec intron_then n ids ltac gls = - if n<=0 then +let rec intron_then n ids ltac gls = + if n<=0 then ltac ids gls - else - let id = pf_get_new_id (id_of_string "_tmp") gls in - tclTHEN - (intro_mustbe_force id) - (intron_then (pred n) (id::ids) ltac) gls + else + let id = pf_get_new_id (id_of_string "_tmp") gls in + tclTHEN + (intro_mustbe_force id) + (intron_then (pred n) (id::ids) ltac) gls let rec consider_match may_intro introduced available expected gls = - match available,expected with + match available,expected with [],[] -> tclIDTAC gls | _,[] -> error "Last statements do not match a complete hypothesis." (* should tell which ones *) - | [],hyps -> + | [],hyps -> if may_intro then begin let id = pf_get_new_id (id_of_string "_tmp") gls in - tclIFTHENELSE + tclIFTHENELSE (intro_mustbe_force id) - (consider_match true [] [id] hyps) - (fun _ -> + (consider_match true [] [id] hyps) + (fun _ -> error "Not enough sub-hypotheses to match statements.") - gls - end + gls + end else error "Not enough sub-hypotheses to match statements." (* should tell which ones *) | id::rest_ids,(Hvar st | Hprop st)::rest -> tclIFTHENELSE (convert_hyp (id,None,st.st_it)) begin - match st.st_label with - Anonymous -> + match st.st_label with + Anonymous -> consider_match may_intro ((id,false)::introduced) rest_ids rest - | Name hid -> - tclTHENLIST + | Name hid -> + tclTHENLIST [rename_hyp [id,hid]; consider_match may_intro ((hid,true)::introduced) rest_ids rest] end begin - (fun gls -> + (fun gls -> let nhyps = - try conjunction_arity id gls with - Not_found -> error "Matching hypothesis not found." in - tclTHENLIST + try conjunction_arity id gls with + Not_found -> error "Matching hypothesis not found." in + tclTHENLIST [general_case_analysis false (mkVar id,NoBindings); intron_then nhyps [] - (fun l -> consider_match may_intro introduced + (fun l -> consider_match may_intro introduced (List.rev_append l rest_ids) expected)] gls) end gls - + let consider_tac c hyps gls = match kind_of_term (strip_outer_cast c) with Var id -> - consider_match false [] [id] hyps gls - | _ -> + consider_match false [] [id] hyps gls + | _ -> let id = pf_get_new_id (id_of_string "_tmp") gls in - tclTHEN + tclTHEN (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c) - (consider_match false [] [id] hyps) gls - + (consider_match false [] [id] hyps) gls + let given_tac hyps gls = consider_match true [] [] hyps gls @@ -792,22 +790,22 @@ let given_tac hyps gls = let rec take_tac wits gls = match wits with [] -> tclIDTAC gls - | wit::rest -> - let typ = pf_type_of gls wit in + | wit::rest -> + let typ = pf_type_of gls wit in tclTHEN (thus_tac wit typ []) (take_tac rest) gls (* tactics for define *) let rec build_function args body = - match args with - st::rest -> + match args with + st::rest -> let pfun= lift 1 (build_function rest body) in let id = match st.st_label with Anonymous -> assert false | Name id -> id in mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun) - | [] -> body + | [] -> body let define_tac id args body gls = let t = build_function args body in @@ -815,43 +813,37 @@ let define_tac id args body gls = (* tactics for reconsider *) -let cast_tac id_or_thesis typ gls = +let cast_tac id_or_thesis typ gls = match id_or_thesis with This id -> let (_,body,_) = pf_get_hyp gls id in convert_hyp (id,body,typ) gls - | Thesis (For _ ) -> + | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." - | Thesis Plain -> + | Thesis Plain -> convert_concl typ DEFAULTcast gls - + (* per cases *) let is_rec_pos (main_ind,wft) = match main_ind with None -> false - | Some index -> + | Some index -> match fst (Rtree.dest_node wft) with Mrec i when i = index -> true | _ -> false let rec constr_trees (main_ind,wft) ind = match Rtree.dest_node wft with - Norec,_ -> - let itree = - (snd (Global.lookup_inductive ind)).mind_recargs in + Norec,_ -> + let itree = + (snd (Global.lookup_inductive ind)).mind_recargs in constr_trees (None,itree) ind | _,constrs -> main_ind,constrs -let constr_args rp constr = - let main_ind,constrs = constr_trees rp (fst constr) in - let ctree = constrs.(pred (snd constr)) in - array_map_to_list (fun t -> main_ind,t) - (snd (Rtree.dest_node ctree)) - let ind_args rp ind = let main_ind,constrs = constr_trees rp ind in - let args ctree = + let args ctree = Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in Array.map args constrs @@ -862,7 +854,7 @@ let init_tree ids ind rp nexti = let map_tree_rp rp id_fun mapi = function Split_patt (ids,ind,branches) -> - let indargs = ind_args rp ind in + let indargs = ind_args rp ind in let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in Split_patt (id_fun ids,ind,Array.mapi do_i branches) | _ -> failwith "map_tree_rp: not a splitting node" @@ -874,19 +866,19 @@ let map_tree id_fun mapi = function | _ -> failwith "map_tree: not a splitting node" -let start_tree env ind rp = +let start_tree env ind rp = init_tree Idset.empty ind rp (fun _ _ -> None) -let build_per_info etype casee gls = +let build_per_info etype casee gls = let concl=pf_concl gls in let env=pf_env gls in let ctyp=pf_type_of gls casee in - let is_dep = dependent casee concl in + let is_dep = dependent casee concl in let hd,args = decompose_app (special_whd gls ctyp) in - let ind = + let ind = try - destInd hd - with _ -> + destInd hd + with _ -> error "Case analysis must be done on an inductive object." in let mind,oind = Global.lookup_inductive ind in let nparams,index = @@ -894,10 +886,10 @@ let build_per_info etype casee gls = ET_Induction -> mind.mind_nparams_rec,Some (snd ind) | _ -> mind.mind_nparams,None in let params,real_args = list_chop nparams args in - let abstract_obj c body = - let typ=pf_type_of gls c in + let abstract_obj c body = + let typ=pf_type_of gls c in lambda_create env (typ,subst_term c body) in - let pred= List.fold_right abstract_obj + let pred= List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in is_dep, {per_casee=casee; @@ -906,7 +898,7 @@ let build_per_info etype casee gls = per_pred=pred; per_args=real_args; per_params=params; - per_nparams=nparams; + per_nparams=nparams; per_wf=index,oind.mind_recargs} let per_tac etype casee gls= @@ -915,25 +907,25 @@ let per_tac etype casee gls= match casee with Real c -> let is_dep,per_info = build_per_info etype c gls in - let ek = + let ek = if is_dep then EK_dep (start_tree env per_info.per_ind per_info.per_wf) else EK_unknown in - tcl_change_info + tcl_change_info {pm_stack= Per(etype,per_info,ek,[])::info.pm_stack} gls | Virtual cut -> assert (cut.cut_stat.st_label=Anonymous); let id = pf_get_new_id (id_of_string "anonymous_matched") gls in let c = mkVar id in - let modified_cut = + let modified_cut = {cut with cut_stat={cut.cut_stat with st_label=Name id}} in - tclTHEN + tclTHEN (instr_cut (fun _ _ c -> c) false false modified_cut) (fun gls0 -> let is_dep,per_info = build_per_info etype c gls0 in assert (not is_dep); - tcl_change_info + tcl_change_info {pm_stack= Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0) gls @@ -950,7 +942,7 @@ let register_nodep_subcase id= function end | _ -> anomaly "wrong stack state" -let suppose_tac hyps gls0 = +let suppose_tac hyps gls0 = let info = get_its_info gls0 in let thesis = pf_concl gls0 in let id = pf_get_new_id (id_of_string "subcase_") gls0 in @@ -958,13 +950,13 @@ let suppose_tac hyps gls0 = let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let old_clauses,stack = register_nodep_subcase id info.pm_stack in let ninfo2 = {pm_stack=stack} in - tclTHENS (assert_postpone id clause) + tclTHENS (assert_postpone id clause) [tclTHENLIST [tcl_change_info ninfo1; assume_tac hyps; clear old_clauses]; tcl_change_info ninfo2] gls0 -(* suppose it is ... *) +(* suppose it is ... *) (* pattern matching compiling *) @@ -975,20 +967,20 @@ let rec skip_args rest ids n = Skip_patt (ids,skip_args rest ids (pred n)) let rec tree_of_pats ((id,_) as cpl) pats = - match pats with + match pats with [] -> End_patt cpl | args::stack -> match args with [] -> Close_patt (tree_of_pats cpl stack) | (patt,rp) :: rest_args -> match patt with - PatVar (_,v) -> + PatVar (_,v) -> Skip_patt (Idset.singleton id, tree_of_pats cpl (rest_args::stack)) | PatCstr (_,(ind,cnum),args,nam) -> let nexti i ati = - if i = pred cnum then - let nargs = + if i = pred cnum then + let nargs = list_map_i (fun j a -> (a,ati.(j))) 0 args in Some (Idset.singleton id, tree_of_pats cpl (nargs::rest_args::stack)) @@ -996,49 +988,49 @@ let rec tree_of_pats ((id,_) as cpl) pats = in init_tree Idset.empty ind rp nexti let rec add_branch ((id,_) as cpl) pats tree= - match pats with - [] -> + match pats with + [] -> begin match tree with - End_patt cpl0 -> End_patt cpl0 - (* this ensures precedence for overlapping patterns *) + End_patt cpl0 -> End_patt cpl0 + (* this ensures precedence for overlapping patterns *) | _ -> anomaly "tree is expected to end here" end | args::stack -> - match args with + match args with [] -> begin match tree with - Close_patt t -> + Close_patt t -> Close_patt (add_branch cpl stack t) - | _ -> anomaly "we should pop here" + | _ -> anomaly "we should pop here" end | (patt,rp) :: rest_args -> match patt with PatVar (_,v) -> begin - match tree with - Skip_patt (ids,t) -> + match tree with + Skip_patt (ids,t) -> Skip_patt (Idset.add id ids, add_branch cpl (rest_args::stack) t) | Split_patt (_,_,_) -> map_tree (Idset.add id) - (fun i bri -> - append_branch cpl 1 (rest_args::stack) bri) + (fun i bri -> + append_branch cpl 1 (rest_args::stack) bri) tree - | _ -> anomaly "No pop/stop expected here" + | _ -> anomaly "No pop/stop expected here" end | PatCstr (_,(ind,cnum),args,nam) -> match tree with Skip_patt (ids,t) -> let nexti i ati = - if i = pred cnum then - let nargs = + if i = pred cnum then + let nargs = list_map_i (fun j a -> (a,ati.(j))) 0 args in Some (Idset.add id ids, add_branch cpl (nargs::rest_args::stack) (skip_args t ids (Array.length ati))) - else + else Some (ids, skip_args t ids (Array.length ati)) in init_tree ids ind rp nexti @@ -1047,30 +1039,30 @@ let rec add_branch ((id,_) as cpl) pats tree= (* this can happen with coercions *) "Case pattern belongs to wrong inductive type."; let mapi i ati bri = - if i = pred cnum then - let nargs = + if i = pred cnum then + let nargs = list_map_i (fun j a -> (a,ati.(j))) 0 args in - append_branch cpl 0 + append_branch cpl 0 (nargs::rest_args::stack) bri else bri in map_tree_rp rp (fun ids -> ids) mapi tree | _ -> anomaly "No pop/stop expected here" and append_branch ((id,_) as cpl) depth pats = function - Some (ids,tree) -> + Some (ids,tree) -> Some (Idset.add id ids,append_tree cpl depth pats tree) | None -> Some (Idset.singleton id,tree_of_pats cpl pats) and append_tree ((id,_) as cpl) depth pats tree = if depth<=0 then add_branch cpl pats tree else match tree with - Close_patt t -> + Close_patt t -> Close_patt (append_tree cpl (pred depth) pats t) - | Skip_patt (ids,t) -> + | Skip_patt (ids,t) -> Skip_patt (Idset.add id ids,append_tree cpl depth pats t) | End_patt _ -> anomaly "Premature end of branch" - | Split_patt (_,_,_) -> - map_tree (Idset.add id) - (fun i bri -> append_branch cpl (succ depth) pats bri) tree + | Split_patt (_,_,_) -> + map_tree (Idset.add id) + (fun i bri -> append_branch cpl (succ depth) pats bri) tree (* suppose it is *) @@ -1084,22 +1076,22 @@ let thesis_for obj typ per_info env= let cind,all_args=decompose_app typ in let ind = destInd cind in let _ = if ind <> per_info.per_ind then - errorlabstrm "thesis_for" - ((Printer.pr_constr_env env obj) ++ spc () ++ - str"cannot give an induction hypothesis (wrong inductive type).") in + errorlabstrm "thesis_for" + ((Printer.pr_constr_env env obj) ++ spc () ++ + str"cannot give an induction hypothesis (wrong inductive type).") in let params,args = list_chop per_info.per_nparams all_args in let _ = if not (List.for_all2 eq_constr params per_info.per_params) then - errorlabstrm "thesis_for" - ((Printer.pr_constr_env env obj) ++ spc () ++ + errorlabstrm "thesis_for" + ((Printer.pr_constr_env env obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in compose_prod rc (whd_beta Evd.empty hd2) let rec build_product_dep pat_info per_info args body gls = - match args with - (Hprop {st_label=nam;st_it=This c} - | Hvar {st_label=nam;st_it=c})::rest -> - let pprod= + match args with + (Hprop {st_label=nam;st_it=This c} + | Hvar {st_label=nam;st_it=c})::rest -> + let pprod= lift 1 (build_product_dep pat_info per_info rest body gls) in let lbody = match nam with @@ -1107,7 +1099,7 @@ let rec build_product_dep pat_info per_info args body gls = | Name id -> subst_var id pprod in mkProd (nam,c,lbody) | Hprop ({st_it=Thesis tk} as st)::rest -> - let pprod= + let pprod= lift 1 (build_product_dep pat_info per_info rest body gls) in let lbody = match st.st_label with @@ -1117,14 +1109,14 @@ let rec build_product_dep pat_info per_info args body gls = match tk with For id -> let obj = mkVar id in - let typ = - try st_assoc (Name id) pat_info.pat_vars - with Not_found -> + let typ = + try st_assoc (Name id) pat_info.pat_vars + with Not_found -> snd (st_assoc (Name id) pat_info.pat_aliases) in thesis_for obj typ per_info (pf_env gls) | Plain -> pf_concl gls in mkProd (st.st_label,ptyp,lbody) - | [] -> body + | [] -> body let build_dep_clause params pat_info per_info hyps gls = let concl= @@ -1138,35 +1130,35 @@ let build_dep_clause params pat_info per_info hyps gls = let let_one_in st body = match st.st_label with Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body) - | Name id -> + | Name id -> mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in - let aliased_clause = + let aliased_clause = List.fold_right let_one_in pat_info.pat_aliases open_clause in List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause let rec register_dep_subcase id env per_info pat = function EK_nodep -> error "Only \"suppose it is\" can be used here." - | EK_unknown -> + | EK_unknown -> register_dep_subcase id env per_info pat (EK_dep (start_tree env per_info.per_ind per_info.per_wf)) | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree) - + let case_tac params pat_info hyps gls0 = let info = get_its_info gls0 in let id = pf_get_new_id (id_of_string "subcase_") gls0 in let et,per_info,ek,old_clauses,rest = match info.pm_stack with - Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) + Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) | _ -> anomaly "wrong place for cases" in let clause = build_dep_clause params pat_info per_info hyps gls0 in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let nek = - register_dep_subcase (id,(List.length params,List.length hyps)) (pf_env gls0) per_info - pat_info.pat_pat ek in + register_dep_subcase (id,(List.length params,List.length hyps)) + (pf_env gls0) per_info pat_info.pat_pat ek in let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in - tclTHENS (assert_postpone id clause) - [tclTHENLIST - [tcl_change_info ninfo1; + tclTHENS (assert_postpone id clause) + [tclTHENLIST + [tcl_change_info ninfo1; assume_st (params@pat_info.pat_vars); assume_st_letin pat_info.pat_aliases; assume_hyps_or_theses hyps; @@ -1181,23 +1173,23 @@ type instance_stack = let initial_instance_stack ids = List.map (fun id -> id,[None,[]]) ids -let push_one_arg arg = function +let push_one_arg arg = function [] -> anomaly "impossible" - | (head,args) :: ctx -> + | (head,args) :: ctx -> ((head,(arg::args)) :: ctx) let push_arg arg stacks = List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks - -let push_one_head c ids (id,stack) = + +let push_one_head c ids (id,stack) = let head = if Idset.mem id ids then Some c else None in id,(head,[]) :: stack let push_head c ids stacks = List.map (push_one_head c ids) stacks -let pop_one (id,stack) = +let pop_one (id,stack) = let nstack= match stack with [] -> anomaly "impossible" @@ -1212,28 +1204,26 @@ let pop_one (id,stack) = let pop_stacks stacks = List.map pop_one stacks -let patvar_base = id_of_string "__" - let hrec_for fix_id per_info gls obj_id = let obj=mkVar obj_id in let typ=pf_get_hyp_typ gls obj_id in let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in let ind = destInd cind in assert (ind=per_info.per_ind); - let params,args= list_chop per_info.per_nparams all_args in + let params,args= list_chop per_info.per_nparams all_args in assert begin - try List.for_all2 eq_constr params per_info.per_params with + try List.for_all2 eq_constr params per_info.per_params with Invalid_argument _ -> false end; - let hd2 = applist (mkVar fix_id,args@[obj]) in + let hd2 = applist (mkVar fix_id,args@[obj]) in compose_lam rc (whd_beta gls.sigma hd2) let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = match tree, objs with - Close_patt t,_ -> - let args0 = pop_stacks args in + Close_patt t,_ -> + let args0 = pop_stacks args in execute_cases fix_name per_info tacnext args0 objs nhrec t gls - | Skip_patt (_,t),skipped::next_objs -> + | Skip_patt (_,t),skipped::next_objs -> let args0 = push_arg skipped args in execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls | End_patt (id,(nparams,nhyps)),[] -> @@ -1260,66 +1250,66 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let hd,all_args = decompose_app (special_whd gls ctyp) in let _ = assert (destInd hd = ind) in (* just in case *) let params,real_args = list_chop nparams all_args in - let abstract_obj c body = - let typ=pf_type_of gls c in + let abstract_obj c body = + let typ=pf_type_of gls c in lambda_create env (typ,subst_term c body) in - let elim_pred = List.fold_right abstract_obj + let elim_pred = List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in let case_info = Inductiveops.make_case_info env ind RegularStyle in let gen_arities = Inductive.arities_of_constructors ind spec in - let f_ids typ = - let sign = - fst (Sign.decompose_prod_assum (Term.prod_applist typ params)) in + let f_ids typ = + let sign = + (prod_assum (Term.prod_applist typ params)) in find_intro_names sign gls in let constr_args_ids = Array.map f_ids gen_arities in - let case_term = + let case_term = mkCase(case_info,elim_pred,casee, Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in let branch_tac i (recargs,bro) gls0 = let args_ids = constr_args_ids.(i) in let rec aux n = function - [] -> - assert (n=Array.length recargs); + [] -> + assert (n=Array.length recargs); next_objs,[],nhrec - | id :: q -> + | id :: q -> let objs,recs,nrec = aux (succ n) q in - if recargs.(n) - then (mkVar id::objs),(id::recs),succ nrec + if recargs.(n) + then (mkVar id::objs),(id::recs),succ nrec else (mkVar id::objs),recs,nrec in let objs,recs,nhrec = aux 0 args_ids in tclTHENLIST [tclMAP intro_mustbe_force args_ids; begin - fun gls1 -> - let hrecs = - List.map - (fun id -> - hrec_for (out_name fix_name) per_info gls1 id) + fun gls1 -> + let hrecs = + List.map + (fun id -> + hrec_for (out_name fix_name) per_info gls1 id) recs in generalize hrecs gls1 end; match bro with - None -> + None -> msg_warning (str "missing case"); tacnext (mkMeta 1) | Some (sub_ids,tree) -> let br_args = - List.filter - (fun (id,_) -> Idset.mem id sub_ids) args in - let construct = + List.filter + (fun (id,_) -> Idset.mem id sub_ids) args in + let construct = applist (mkConstruct(ind,succ i),params) in - let p_args = + let p_args = push_head construct ids br_args in - execute_cases fix_name per_info tacnext + execute_cases fix_name per_info tacnext p_args objs nhrec tree] gls0 in - tclTHENSV + tclTHENSV (refine case_term) (Array.mapi branch_tac br) gls - | Split_patt (_, _, _) , [] -> + | Split_patt (_, _, _) , [] -> anomaly "execute_cases : Nothing to split" - | Skip_patt _ , [] -> + | Skip_patt _ , [] -> anomaly "execute_cases : Nothing to skip" - | End_patt (_,_) , _ :: _ -> + | End_patt (_,_) , _ :: _ -> anomaly "execute_cases : End of branch with garbage left" let understand_my_constr c gls = @@ -1337,41 +1327,41 @@ let refine = ref (fun (_:open_constr) -> (assert false : tactic) ) in !refine oc gls)) (* end focus/claim *) - + let end_tac et2 gls = let info = get_its_info gls in - let et1,pi,ek,clauses = + let et1,pi,ek,clauses = match info.pm_stack with - Suppose_case::_ -> + Suppose_case::_ -> anomaly "This case should already be trapped" - | Claim::_ -> + | Claim::_ -> error "\"end claim\" expected." | Focus_claim::_ -> error "\"end focus\" expected." - | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) - | [] -> + | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) + | [] -> anomaly "This case should already be trapped" in - let et = + let et = if et1 <> et2 then - match et1 with - ET_Case_analysis -> + match et1 with + ET_Case_analysis -> error "\"end cases\" expected." | ET_Induction -> error "\"end induction\" expected." else et1 in - tclTHEN + tclTHEN tcl_erase_info begin match et,ek with - _,EK_unknown -> - tclSOLVE [simplest_elim pi.per_casee] + _,EK_unknown -> + tclSOLVE [simplest_elim pi.per_casee] | ET_Case_analysis,EK_nodep -> - tclTHEN + tclTHEN (general_case_analysis false (pi.per_casee,NoBindings)) (default_justification (List.map mkVar clauses)) | ET_Induction,EK_nodep -> tclTHENLIST - [generalize (pi.per_args@[pi.per_casee]); + [generalize (pi.per_args@[pi.per_casee]); simple_induct (AnonHyp (succ (List.length pi.per_args))); default_justification (List.map mkVar clauses)] | ET_Case_analysis,EK_dep tree -> @@ -1385,57 +1375,48 @@ let end_tac et2 gls = let nargs = (List.length pi.per_args) in tclTHEN (generalize (pi.per_args@[pi.per_casee])) begin - fun gls0 -> - let fix_id = + fun gls0 -> + let fix_id = pf_get_new_id (id_of_string "_fix") gls0 in - let c_id = + let c_id = pf_get_new_id (id_of_string "_main_arg") gls0 in tclTHENLIST [fix (Some fix_id) (succ nargs); tclDO nargs introf; intro_mustbe_force c_id; - execute_cases (Name fix_id) pi + execute_cases (Name fix_id) pi (fun c -> - tclTHENLIST + tclTHENLIST [clear [fix_id]; my_refine c; clear clauses; justification assumption]) - (initial_instance_stack clauses) + (initial_instance_stack clauses) [mkVar c_id] 0 tree] gls0 - end + end end gls (* escape *) -let rec abstract_metas n avoid head = function - [] -> 1,head,[] - | (meta,typ)::rest -> - let id = next_ident_away (id_of_string "_sbgl") avoid in - let p,term,args = abstract_metas (succ n) (id::avoid) head rest in - succ p,mkLambda(Name id,typ,subst_meta [meta,mkRel p] term), - (mkMeta n)::args - - let escape_tac gls = tcl_erase_info gls (* General instruction engine *) -let rec do_proof_instr_gen _thus _then instr = - match instr with - Pthus i -> +let rec do_proof_instr_gen _thus _then instr = + match instr with + Pthus i -> assert (not _thus); do_proof_instr_gen true _then i - | Pthen i -> + | Pthen i -> assert (not _then); do_proof_instr_gen _thus true i - | Phence i -> + | Phence i -> assert (not (_then || _thus)); do_proof_instr_gen true true i | Pcut c -> instr_cut mk_stat_or_thesis _thus _then c | Psuffices c -> - instr_suffices _then c + instr_suffices _then c | Prew (s,c) -> assert (not _then); instr_rew _thus s c @@ -1443,75 +1424,75 @@ let rec do_proof_instr_gen _thus _then instr = | Pgiven hyps -> given_tac hyps | Passume hyps -> assume_tac hyps | Plet hyps -> assume_tac hyps - | Pclaim st -> instr_claim false st + | Pclaim st -> instr_claim false st | Pfocus st -> instr_claim true st | Ptake witl -> take_tac witl | Pdefine (id,args,body) -> define_tac id args body - | Pcast (id,typ) -> cast_tac id typ - | Pper (et,cs) -> per_tac et cs + | Pcast (id,typ) -> cast_tac id typ + | Pper (et,cs) -> per_tac et cs | Psuppose hyps -> suppose_tac hyps | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps | Pend (B_elim et) -> end_tac et | Pend _ -> anomaly "Not applicable" | Pescape -> escape_tac - + let eval_instr {instr=instr} = - do_proof_instr_gen false false instr + do_proof_instr_gen false false instr let rec preprocess pts instr = match instr with Phence i |Pthus i | Pthen i -> preprocess pts i - | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ - | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ + | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ + | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Pper _ | Prew _ -> check_not_per pts; true,pts - | Pescape -> + | Pescape -> check_not_per pts; true,pts - | Pcase _ | Psuppose _ | Pend (B_elim _) -> + | Pcase _ | Psuppose _ | Pend (B_elim _) -> true,close_previous_case pts - | Pend bt -> - false,close_block bt pts - -let rec postprocess pts instr = + | Pend bt -> + false,close_block bt pts + +let rec postprocess pts instr = match instr with Phence i | Pthus i | Pthen i -> postprocess pts i | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> pts - | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ + | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ | Pescape -> nth_unproven 1 pts | Pend (B_elim ET_Induction) -> begin let pf = proof_of_pftreestate pts in let (pfterm,_) = extract_open_pftreestate pts in let env = Evd.evar_env (goal_of_proof pf) in - try + try Inductiveops.control_only_guard env pfterm; goto_current_focus_or_top (mark_as_done pts) - with + with Type_errors.TypeError(env, Type_errors.IllFormedRecBody(_,_,_,_,_)) -> anomaly "\"end induction\" generated an ill-formed fixpoint" end - | Pend _ -> + | Pend _ -> goto_current_focus_or_top (mark_as_done pts) let do_instr raw_instr pts = let has_tactic,pts1 = preprocess pts raw_instr.instr in - let pts2 = + let pts2 = if has_tactic then let gl = nth_goal_of_pftreestate 1 pts1 in let env= pf_env gl in let sigma= project gl in - let ist = {ltacvars = ([],[]); ltacrecvars = []; + let ist = {ltacvars = ([],[]); ltacrecvars = []; gsigma = sigma; genv = env} in let glob_instr = intern_proof_instr ist raw_instr in - let instr = + let instr = interp_proof_instr (get_its_info gl) sigma env glob_instr in let lock_focus = is_focussing_instr instr.instr in let marker= Proof_instr (lock_focus,instr) in - solve_nth_pftreestate 1 + solve_nth_pftreestate 1 (abstract_operation marker (tclTHEN (eval_instr instr) clean_tmp)) pts1 else pts1 in postprocess pts2 raw_instr.instr @@ -1522,8 +1503,8 @@ let proof_instr raw_instr = (* (* STUFF FOR ITERATED RELATIONS *) -let decompose_bin_app t= - let hd,args = destApp +let decompose_bin_app t= + let hd,args = destApp let identify_transitivity_lemma c = let varx,tx,c1 = destProd c in @@ -1534,4 +1515,4 @@ let identify_transitivity_lemma c = let p2=pop lp2 in let p3=pop lp3 in *) - + diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli index 5f4a0485..1cfcfedf 100644 --- a/tactics/decl_proof_instr.mli +++ b/tactics/decl_proof_instr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: decl_proof_instr.mli 12422 2009-10-27 08:42:49Z corbinea $ *) +(* $Id$ *) open Refiner open Names @@ -23,7 +23,8 @@ val automation_tac : tactic val daimon_subtree: pftreestate -> pftreestate -val concl_refiner: Termops.metamap -> constr -> Proof_type.goal sigma -> constr +val concl_refiner: + Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr val do_instr: Decl_expr.raw_proof_instr -> pftreestate -> pftreestate val proof_instr: Decl_expr.raw_proof_instr -> unit @@ -76,27 +77,27 @@ val thesis_for : Term.constr -> val close_previous_case : pftreestate -> pftreestate val pop_stacks : - (Names.identifier * - (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Names.identifier * + (Term.constr option * Term.constr list) list) list -> + (Names.identifier * (Term.constr option * Term.constr list) list) list val push_head : Term.constr -> Names.Idset.t -> - (Names.identifier * + (Names.identifier * (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Names.identifier * (Term.constr option * Term.constr list) list) list val push_arg : Term.constr -> - (Names.identifier * + (Names.identifier * (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Names.identifier * (Term.constr option * Term.constr list) list) list -val hrec_for: +val hrec_for: Names.identifier -> - Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> + Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> Names.identifier -> Term.constr val consider_match : diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index f3e1559f..96d83b97 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -6,10 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: dhyp.ml 11739 2009-01-02 19:33:19Z herbelin $ *) +(* $Id$ *) (* Chet's comments about this tactic : - + Programmable destruction of hypotheses and conclusions. The idea here is that we are going to store patterns. These @@ -136,7 +136,7 @@ open Libnames (* two patterns - one for the type, and one for the type of the type *) type destructor_pattern = { - d_typ: constr_pattern; + d_typ: constr_pattern; d_sort: constr_pattern } let subst_destructor_pattern subst { d_typ = t; d_sort = s } = @@ -151,96 +151,88 @@ type located_destructor_pattern = destructor_pattern) location let subst_located_destructor_pattern subst = function - | HypLocation (b,d,d') -> + | HypLocation (b,d,d') -> HypLocation (b,subst_destructor_pattern subst d, subst_destructor_pattern subst d') | ConclLocation d -> ConclLocation (subst_destructor_pattern subst d) + type destructor_data = { d_pat : located_destructor_pattern; d_pri : int; d_code : identifier option * glob_tactic_expr (* should be of phylum tactic *) } -type t = (identifier,destructor_data) Nbtermdn.t -type frozen_t = (identifier,destructor_data) Nbtermdn.frozen_t +module Dest_data = struct + type t = destructor_data + let compare = Pervasives.compare + end + +module Nbterm_net = Nbtermdn.Make(Dest_data) + +type t = identifier Nbterm_net.t +type frozen_t = identifier Nbterm_net.frozen_t -let tactab = (Nbtermdn.create () : t) +let tactab = (Nbterm_net.create () : t) -let lookup pat = Nbtermdn.lookup tactab pat +let lookup pat = Nbterm_net.lookup tactab pat -let init () = Nbtermdn.empty tactab -let freeze () = Nbtermdn.freeze tactab -let unfreeze fs = Nbtermdn.unfreeze fs tactab +let init () = Nbterm_net.empty tactab -let rollback f x = - let fs = freeze() in - try f x with e -> (unfreeze fs; raise e) +let freeze () = Nbterm_net.freeze tactab +let unfreeze fs = Nbterm_net.unfreeze fs tactab let add (na,dd) = let pat = match dd.d_pat with | HypLocation(_,p,_) -> p.d_typ | ConclLocation p -> p.d_typ - in - if Nbtermdn.in_dn tactab na then begin - msgnl (str "Warning [Overriding Destructor Entry " ++ + in + if Nbterm_net.in_dn tactab na then begin + msgnl (str "Warning [Overriding Destructor Entry " ++ str (string_of_id na) ++ str"]"); - Nbtermdn.remap tactab na (pat,dd) - end else - Nbtermdn.add tactab (na,(pat,dd)) + Nbterm_net.remap tactab na (pat,dd) + end else + Nbterm_net.add tactab (na,(pat,dd)) -let _ = +let _ = Summary.declare_summary "destruct-hyp-concl" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; - Summary.init_function = init; - Summary.survive_module = false; - Summary.survive_section = false } + Summary.init_function = init } -let forward_subst_tactic = +let forward_subst_tactic = ref (fun _ -> failwith "subst_tactic is not installed for DHyp") -let set_extern_subst_tactic f = forward_subst_tactic := f - let cache_dd (_,(_,na,dd)) = - try + try add (na,dd) - with _ -> + with _ -> anomalylabstrm "Dhyp.add" - (str"The code which adds destructor hints broke;" ++ spc () ++ + (str"The code which adds destructor hints broke;" ++ spc () ++ str"this is not supposed to happen") -let classify_dd (_,(local,_,_ as o)) = +let classify_dd (local,_,_ as o) = if local then Dispose else Substitute o -let export_dd (local,_,_ as x) = if local then None else Some x - -let subst_dd (_,subst,(local,na,dd)) = +let subst_dd (subst,(local,na,dd)) = (local,na, { d_pat = subst_located_destructor_pattern subst dd.d_pat; - d_pri = dd.d_pri; + d_pri = dd.d_pri; d_code = !forward_subst_tactic subst dd.d_code }) -let (inDD,outDD) = +let (inDD,_) = declare_object {(default_object "DESTRUCT-HYP-CONCL-DATA") with cache_function = cache_dd; open_function = (fun i o -> if i=1 then cache_dd o); subst_function = subst_dd; - classify_function = classify_dd; - export_function = export_dd } - -let forward_intern_tac = - ref (fun _ -> failwith "intern_tac is not installed for DHyp") - -let set_extern_intern_tac f = forward_intern_tac := f + classify_function = classify_dd } let catch_all_sort_pattern = PMeta(Some (id_of_string "SORT")) let catch_all_type_pattern = PMeta(Some (id_of_string "TYPE")) - -let add_destructor_hint local na loc pat pri code = - let code = !forward_intern_tac code in + +let add_destructor_hint local na loc (_,pat) pri code = let code = begin match loc, code with | HypLocation _, TacFun ([id],body) -> (id,body) @@ -249,8 +241,6 @@ let add_destructor_hint local na loc pat pri code = errorlabstrm "add_destructor_hint" (str "The tactic should be a function of the hypothesis name.") end in - let (_,pat) = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat - in let pat = match loc with | HypLocation b -> HypLocation @@ -289,18 +279,18 @@ let match_dpat dp cls gls = then error "No match." | _ -> error "ApplyDestructor" -let forward_interp_tactic = +let forward_interp_tactic = ref (fun _ -> failwith "interp_tactic is not installed for DHyp") let set_extern_interp f = forward_interp_tactic := f let applyDestructor cls discard dd gls = match_dpat dd.d_pat cls gls; - let cll = simple_clause_list_of cls gls in + let cll = simple_clause_of cls gls in let tacl = List.map (fun cl -> match cl, dd.d_code with - | Some ((_,id),_), (Some x, tac) -> + | Some id, (Some x, tac) -> let arg = ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in TacLetIn (false, [(dummy_loc, x), arg], tac) @@ -311,7 +301,7 @@ let applyDestructor cls discard dd gls = let discard_0 = List.map (fun cl -> match (cl,dd.d_pat) with - | (Some ((_,id),_),HypLocation(discardable,_,_)) -> + | (Some id,HypLocation(discardable,_,_)) -> if discard & discardable then thin [id] else tclIDTAC | (None,ConclLocation _) -> tclIDTAC | _ -> error "ApplyDestructor" ) cll in @@ -330,7 +320,6 @@ let destructHyp discard id gls = let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in tclFIRST (List.map (applyDestructor (onHyp id) discard) sorted_ddl) gls -let cDHyp id gls = destructHyp true id gls let dHyp id gls = destructHyp false id gls let h_destructHyp b id = @@ -349,22 +338,20 @@ let dConcl gls = let h_destructConcl = abstract_tactic TacDestructConcl dConcl -let to2Lists (table : t) = Nbtermdn.to2lists table - let rec search n = if n=0 then error "Search has reached zero."; tclFIRST [intros; assumption; - (tclTHEN - (Tacticals.tryAllClauses - (function - | Some ((_,id),_) -> (dHyp id) + (tclTHEN + (Tacticals.tryAllHypsAndConcl + (function + | Some id -> (dHyp id) | None -> dConcl )) (search (n-1)))] - + let auto_tdb n = tclTRY (tclCOMPLETE (search n)) - + let search_depth_tdb = ref(5) let depth_tdb = function diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli index 630092f0..41fd497f 100644 --- a/tactics/dhyp.mli +++ b/tactics/dhyp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: dhyp.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names @@ -17,7 +17,6 @@ open Tacexpr (* Programmable destruction of hypotheses and conclusions. *) val set_extern_interp : (glob_tactic_expr -> tactic) -> unit -val set_extern_intern_tac : (raw_tactic_expr -> glob_tactic_expr) -> unit (* val dHyp : identifier -> tactic @@ -29,4 +28,5 @@ val h_auto_tdb : int option -> tactic val add_destructor_hint : Vernacexpr.locality_flag -> identifier -> (bool,unit) Tacexpr.location -> - Topconstr.constr_expr -> int -> raw_tactic_expr -> unit + Rawterm.patvar list * Pattern.constr_pattern -> int -> + glob_tactic_expr -> unit diff --git a/tactics/dn.ml b/tactics/dn.ml index 2a8166dc..a0889ab8 100644 --- a/tactics/dn.ml +++ b/tactics/dn.ml @@ -1,100 +1,103 @@ -(* -*- compile-command: "make -C .. bin/coqtop.byte" -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* $Id: dn.ml 11282 2008-07-28 11:51:53Z msozeau $ *) -(* This file implements the basic structure of what Chet called - ``discrimination nets''. If my understanding is right, it serves - to associate actions (for example, tactics) with a priority to term - patterns, so that if a hypothesis matches a pattern in the net, - then the associated tactic is applied. Discrimination nets are used - (only) to implement the tactics Auto, DHyp and Point. - A discrimination net is a tries structure, that is, a tree structure - specially conceived for searching patterns, like for example strings - --see the file Tlm.ml in the directory lib/util--. Here the tries - structure are used for looking for term patterns. - This module is then used in : - - termdn.ml (discrimination nets of terms); - - btermdn.ml (discrimination nets of terms with bounded depth, - used in the tactic auto); - - nbtermdn.ml (named discrimination nets with bounded depth, used - in the tactics Dhyp and Point). - Eduardo (4/8/97) *) -(* Definition of the basic structure *) +module Make = + functor (X : Set.OrderedType) -> + functor (Y : Map.OrderedType) -> + functor (Z : Map.OrderedType) -> +struct + + module Y_tries = struct + type t = (Y.t * int) option + let compare x y = + match x,y with + None,None -> 0 + | Some (l,n),Some (l',n') -> + let m = Y.compare l l' in + if 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 + end -type ('lbl,'pat) decompose_fun = 'pat -> ('lbl * 'pat list) option - -type 'res lookup_res = Label of 'res | Nothing | Everything + module T = Tries.Make(X_tries)(Y_tries) + + type decompose_fun = X.t -> (Y.t * X.t list) option -type ('lbl,'tree) lookup_fun = 'tree -> ('lbl * 'tree list) lookup_res + type 'res lookup_res = Label of 'res | Nothing | Everything + + type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res -type ('lbl,'pat,'inf) t = (('lbl * int) option,'pat * 'inf) Tlm.t + type t = T.t -let create () = Tlm.empty + let create () = T.empty (* [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 :: (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 - pathrec [] - -let tm_of tm lbl = - try [Tlm.map tm lbl, true] with Not_found -> [] - -let rec skip_arg n tm = - if n = 0 then [tm,true] - else - List.flatten - (List.map - (fun a -> match a with - | None -> skip_arg (pred n) (Tlm.map tm a) - | Some (lbl,m) -> - skip_arg (pred n + m) (Tlm.map tm a)) - (Tlm.dom tm)) + 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 :: (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 + pathrec [] + + let tm_of tm lbl = + try [T.map tm lbl, true] with Not_found -> [] -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 -> + let rec skip_arg n tm = + if 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 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.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) -> Tlm.xtract tm) (lookrec t tm)) - -let add tm dna (pat,inf) = - let p = path_of dna pat in Tlm.add tm (p,(pat,inf)) + 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)) + + let add tm dna (pat,inf) = + let p = path_of dna pat in T.add tm (p,(pat,inf)) + + 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 rmv tm dna (pat,inf) = - let p = path_of dna pat in Tlm.rmv tm (p,(pat,inf)) - -let app f tm = Tlm.app (fun (_,p) -> f p) tm - +end + diff --git a/tactics/dn.mli b/tactics/dn.mli index 62e37a73..3cb52a56 100644 --- a/tactics/dn.mli +++ b/tactics/dn.mli @@ -1,46 +1,47 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(*i $Id: dn.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) -(* Discrimination nets. *) -type ('lbl,'tree) decompose_fun = 'tree -> ('lbl * 'tree list) option -type ('lbl,'pat,'inf) t (* = (('lbl * int) option,'pat * 'inf) Tlm.t *) -val create : unit -> ('lbl,'pat,'inf) 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 : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf - -> ('lbl,'pat,'inf) t +module Make : + functor (X : Set.OrderedType) -> + functor (Y : Map.OrderedType) -> + functor (Z : Map.OrderedType) -> +sig -val rmv : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf - -> ('lbl,'pat,'inf) t - -type 'res lookup_res = Label of 'res | Nothing | Everything + type decompose_fun = X.t -> (Y.t * X.t list) option -type ('lbl,'tree) lookup_fun = 'tree -> ('lbl * 'tree list) lookup_res + 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 + + 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 : ('lbl,'pat,'inf) t -> ('lbl,'term) lookup_fun -> 'term - -> ('pat * 'inf) list - -val app : (('pat * 'inf) -> unit) -> ('lbl,'pat,'inf) t -> unit - -val skip_arg : int -> ('lbl,'pat,'inf) t -> (('lbl,'pat,'inf) t * bool) list + + 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 + +end diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 67bdeb46..89f8d72f 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: eauto.ml4 11735 2009-01-02 17:22:31Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -31,14 +31,16 @@ open Auto open Rawterm open Hiddentac -let e_give_exact ?(flags=Unification.default_unify_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in - if occur_existential t1 or occur_existential t2 then +let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_transparent_state } + +let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in + if occur_existential t1 or occur_existential t2 then tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl else exact_check c gl let assumption id = e_give_exact (mkVar id) - -let e_assumption gl = + +let e_assumption gl = tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl TACTIC EXTEND eassumption @@ -49,10 +51,8 @@ TACTIC EXTEND eexact | [ "eexact" constr(c) ] -> [ e_give_exact c ] END -let e_give_exact_constr = h_eexact - -let registered_e_assumption gl = - tclFIRST (List.map (fun id gl -> e_give_exact_constr (mkVar id) gl) +let registered_e_assumption gl = + tclFIRST (List.map (fun id gl -> e_give_exact (mkVar id) gl) (pf_ids_of_hyps gl)) gl (************************************************************************) @@ -93,163 +93,116 @@ open Unification let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) -(* no delta yet *) - -let unify_e_resolve flags (c,clenv) gls = +let unify_e_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in let _ = clenv_unique_resolver false ~flags clenv' gls in h_simplest_eapply c gls -let unify_e_resolve_nodelta (c,clenv) gls = - let clenv' = connect_clenv gls clenv in - let _ = clenv_unique_resolver false clenv' gls in - h_simplest_eapply c gls - -let rec e_trivial_fail_db mod_delta db_list local_db goal = - let tacl = +let rec e_trivial_fail_db db_list local_db goal = + let tacl = registered_e_assumption :: - (tclTHEN Tactics.intro + (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 mod_delta db_list + (e_trivial_fail_db db_list (Hint_db.add_list hintl local_db) g'))) :: - (List.map fst (e_trivial_resolve mod_delta db_list local_db (pf_concl goal)) ) - in - tclFIRST (List.map tclCOMPLETE tacl) goal - -and e_my_find_search mod_delta = - if mod_delta then e_my_find_search_delta - else e_my_find_search_nodelta - -and e_my_find_search_nodelta db_list local_db hdc concl = - let hdc = head_of_constr_reference hdc in - let hintl = - if occur_existential concl then - list_map_append (Hint_db.map_all hdc) (local_db::db_list) - else - list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list) - in - let tac_of_hint = - fun {pri=b; pat = p; code=t} -> - (b, - let tac = - match t with - | Res_pf (term,cl) -> unify_resolve_nodelta (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve_nodelta (term,cl) - | Give_exact (c) -> e_give_exact_constr c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve_nodelta (term,cl)) - (e_trivial_fail_db false db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> conclPattern concl p tacast - in - (tac,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 + (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) + in + tclFIRST (List.map tclCOMPLETE tacl) goal -and e_my_find_search_delta db_list local_db hdc concl = +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 -> + 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) - else - list_map_append (fun db -> + 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) - in - let tac_of_hint = - fun (st, {pri=b; pat = p; code=t}) -> - (b, + in + let tac_of_hint = + fun (st, {pri=b; pat = p; code=t}) -> + (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 ~flags:st c + | Give_exact (c) -> e_give_exact c | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve st (term,cl)) - (e_trivial_fail_db true db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] + tclTHEN (unify_e_resolve 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 - in - (tac,pr_autotactic t)) + in + (tac,lazy (pr_autotactic t))) (*i - fun gls -> pPNL (pr_autotactic t); Format.print_flush (); + 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 (); + with e when Logic.catchable_exception(e) -> + (Format.print_string "Fail\n"; + Format.print_flush (); raise e) i*) - in + in List.map tac_of_hint hintl - -and e_trivial_resolve mod_delta db_list local_db gl = - try - priority - (e_my_find_search mod_delta db_list local_db + +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) with Bound | Not_found -> [] -let e_possible_resolve mod_delta db_list local_db gl = - try List.map snd - (e_my_find_search mod_delta db_list local_db +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) with Bound | Not_found -> [] -let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id)) - -let find_first_goal gls = +let find_first_goal gls = try first_goal gls with UserError _ -> assert false (*s The following module [SearchProblem] is used to instantiate the generic exploration functor [Explore.Make]. *) -type search_state = { +type search_state = { depth : int; (*r depth of search before failing *) tacres : goal list sigma * validation; - last_tactic : std_ppcmds; + last_tactic : std_ppcmds Lazy.t; dblist : Auto.hint_db list; localdb : Auto.hint_db list } - + module SearchProblem = struct - + type state = search_state let success s = (sig_it (fst s.tacres)) = [] let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) - + let pr_goals gls = let evars = Evarutil.nf_evars (Refiner.project gls) in prlist (pr_ev evars) (sig_it gls) - + let filter_tactics (glls,v) l = (* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* let evars = Evarutil.nf_evars (Refiner.project glls) in *) (* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) let rec aux = function | [] -> [] - | (tac,pptac) :: tacl -> - try - let (lgls,ptl) = apply_tac_list tac glls in + | (tac,pptac) :: tacl -> + try + let (lgls,ptl) = apply_tac_list tac glls in let v' p = v (ptl p) in (* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) ((lgls,v'),pptac) :: aux tacl with e -> Refiner.catch_failerror e; aux tacl in aux l - + (* Ordering of states is lexicographic on depth (greatest first) then number of remaining goals. *) let compare s s' = @@ -257,61 +210,61 @@ module SearchProblem = struct let nbgoals s = List.length (sig_it (fst s.tacres)) in if d <> 0 then d else nbgoals s - nbgoals s' - let branching s = - if s.depth = 0 then + let branching s = + if s.depth = 0 then [] - else + else let lg = fst s.tacres in let nbgl = List.length (sig_it lg) in assert (nbgl > 0); let g = find_first_goal lg in - let assumption_tacs = - let l = + let assumption_tacs = + let l = filter_tactics s.tacres - (List.map - (fun id -> (e_give_exact_constr (mkVar id), - (str "exact" ++ spc () ++ pr_id id))) + (List.map + (fun id -> (e_give_exact (mkVar id), + lazy (str "exact" ++ spc () ++ pr_id id))) (pf_ids_of_hyps g)) in List.map (fun (res,pp) -> { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb }) l in - let intro_tac = - List.map - (fun ((lgls,_) as res,pp) -> - let g' = first_goal lgls in - let hintl = + let intro_tac = + List.map + (fun ((lgls,_) as res,pp) -> + let g' = first_goal lgls in + let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') in let ldb = Hint_db.add_list hintl (List.hd s.localdb) in - { depth = s.depth; tacres = res; + { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = ldb :: List.tl s.localdb }) - (filter_tactics s.tacres [Tactics.intro,(str "intro")]) + (filter_tactics s.tacres [Tactics.intro,lazy (str "intro")]) in - let rec_tacs = - let l = - filter_tactics s.tacres (e_possible_resolve false s.dblist (List.hd s.localdb) (pf_concl g)) + let rec_tacs = + let l = + filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) in - List.map - (fun ((lgls,_) as res, pp) -> + List.map + (fun ((lgls,_) as res, pp) -> let nbgl' = List.length (sig_it lgls) in if nbgl' < nbgl then { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb } - else - { depth = pred s.depth; tacres = res; + else + { depth = pred s.depth; tacres = res; dblist = s.dblist; last_tactic = pp; - localdb = + localdb = list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }) l in List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) - let pp s = - msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ - s.last_tactic ++ str "\n")) + let pp s = + msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ + (Lazy.force s.last_tactic) ++ str "\n")) end @@ -320,12 +273,10 @@ module Search = Explore.Make(SearchProblem) let make_initial_state n gl dblist localdb = { depth = n; tacres = tclIDTAC gl; - last_tactic = (mt ()); + last_tactic = lazy (mt()); dblist = dblist; localdb = [localdb] } -let debug_depth_first = Search.debug_depth_first - let e_depth_search debug p db_list local_db gl = try let tac = if debug then Search.debug_depth_first else Search.depth_first in @@ -335,36 +286,36 @@ let e_depth_search debug p db_list local_db gl = let e_breadth_search debug n db_list local_db gl = try - let tac = - if debug then Search.debug_breadth_first else Search.breadth_first + let tac = + if debug then Search.debug_breadth_first else Search.breadth_first in let s = tac (make_initial_state n gl db_list local_db) in s.tacres with Not_found -> error "eauto: breadth first search failed." -let e_search_auto debug (in_depth,p) lems db_list gl = - let local_db = make_local_hint_db true lems gl in - if in_depth then +let e_search_auto debug (in_depth,p) lems db_list gl = + let local_db = make_local_hint_db true lems gl in + if in_depth then e_depth_search debug p db_list local_db gl - else + else e_breadth_search debug p db_list local_db gl open Evd -let eauto_with_bases debug np lems db_list = +let eauto_with_bases debug np lems db_list = tclTRY (e_search_auto debug np lems db_list) -let eauto debug np lems dbnames = +let eauto debug np lems dbnames = let db_list = List.map - (fun x -> + (fun x -> try searchtable_map x with Not_found -> error ("No such Hint database: "^x^".")) - ("core"::dbnames) + ("core"::dbnames) in tclTRY (e_search_auto debug np lems db_list) - -let full_eauto debug n lems gl = + +let full_eauto debug n lems gl = let dbnames = current_db_names () in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map searchtable_map dbnames in @@ -375,7 +326,7 @@ let gen_eauto d np lems = function | Some l -> eauto d np lems l let make_depth = function - | None -> !default_search_depth + | None -> !default_search_depth | Some (ArgArg d) -> d | _ -> error "eauto called with a non closed argument." @@ -398,7 +349,7 @@ ARGUMENT EXTEND hintbases | [ ] -> [ Some [] ] END -let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_coma prc +let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc ARGUMENT EXTEND constr_coma_sequence TYPED AS constr_list @@ -417,52 +368,146 @@ ARGUMENT EXTEND auto_using END TACTIC EXTEND eauto -| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> [ gen_eauto false (make_dimension n p) lems db ] END TACTIC EXTEND new_eauto -| [ "new" "auto" int_or_var_opt(n) auto_using(lems) +| [ "new" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> [ match db with | None -> new_full_auto (make_depth n) lems | Some l -> new_auto (make_depth n) lems l ] END - + TACTIC EXTEND debug_eauto -| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> [ gen_eauto true (make_dimension n p) lems db ] END TACTIC EXTEND dfs_eauto -| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) +| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> [ gen_eauto false (true, make_depth p) lems db ] END +let cons a l = a :: l + +let autounfold db cl = + 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 cl + let autosimpl db cl = let unfold_of_elts constr (b, elts) = - if not b then + if not b then List.map (fun c -> all_occurrences, constr c) elts else [] in - let unfolds = List.concat (List.map (fun dbname -> + let unfolds = List.concat (List.map (fun dbname -> let db = searchtable_map dbname in let (ids, csts) = Hint_db.transparent_state db in unfold_of_elts (fun x -> EvalConstRef x) (Cpred.elements csts) @ unfold_of_elts (fun x -> EvalVarRef x) (Idpred.elements ids)) db) in unfold_option unfolds cl -TACTIC EXTEND autosimpl -| [ "autosimpl" hintbases(db) ] -> - [ autosimpl (match db with None -> ["core"] | Some x -> "core"::x) None ] +TACTIC EXTEND autounfold +| [ "autounfold" hintbases(db) "in" hyp(id) ] -> + [ autounfold (match db with None -> ["core"] | Some x -> x) (Some (id, InHyp)) ] +| [ "autounfold" hintbases(db) ] -> + [ autounfold (match db with None -> ["core"] | Some x -> x) None ] + 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 -> + (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 + | 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 -> + if done_ then done_, arg :: acc + else match aux arg with + | true, arg' -> true, arg' :: acc + | false, arg' -> false, arg :: acc) + (false, []) args + in + if done_ then true, mkApp (f, Array.of_list (List.rev args')) + else false, c) + | _ -> + let done_ = ref false in + let c' = map_constr (fun c -> + if !done_ then c else + let x, c' = aux c in + done_ := x; c') c + in !done_, c' + in aux c + +let autounfold_one db cl gl = + 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 + 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 + +(* 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 cl *) + +(* 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 -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cst)) csts *) +(* (Idset.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *) +(* (tclFAIL 0 (mt())) db *) + +TACTIC EXTEND autounfold_one +| [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> + [ autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, InHyp)) ] +| [ "autounfold_one" hintbases(db) ] -> + [ autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] + END + +TACTIC EXTEND autounfoldify +| [ "autounfoldify" constr(x) ] -> [ + let db = match kind_of_term x with + | Const c -> string_of_label (con_label c) + | _ -> assert false + in autounfold ["core";db] None ] END TACTIC EXTEND unify | ["unify" constr(x) constr(y) ] -> [ unify x y ] -| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ +| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ unify ~state:(Hint_db.transparent_state (searchtable_map base)) x y ] END + + +TACTIC EXTEND convert_concl_no_check +| ["convert_concl_no_check" constr(x) ] -> [ convert_concl_no_check x DEFAULTcast ] +END diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 1c6f9920..b708949e 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -25,9 +25,9 @@ val e_assumption : tactic val registered_e_assumption : tactic -val e_give_exact_constr : constr -> tactic +val e_give_exact : ?flags:Unification.unify_flags -> constr -> tactic -val gen_eauto : bool -> bool * int -> constr list -> +val gen_eauto : bool -> bool * int -> constr list -> hint_db_name list option -> tactic @@ -35,3 +35,5 @@ val eauto_with_bases : bool -> bool * int -> Term.constr list -> Auto.hint_db list -> Proof_type.tactic + +val autounfold : hint_db_name list -> Tacticals.goal_location -> tactic diff --git a/tactics/elim.ml b/tactics/elim.ml index fa4a7caa..cac200f5 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: elim.ml 11739 2009-01-02 19:33:19Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -28,12 +28,12 @@ open Genarg open Tacexpr let introElimAssumsThen tac ba = - let nassums = - List.fold_left - (fun acc b -> if b then acc+2 else acc+1) - 0 ba.branchsign - in - let introElimAssums = tclDO nassums intro in + let nassums = + List.fold_left + (fun acc b -> if b then acc+2 else acc+1) + 0 ba.branchsign + in + let introElimAssums = tclDO nassums intro in (tclTHEN introElimAssums (elim_on_ba tac ba)) let introCaseAssumsThen tac ba = @@ -41,12 +41,12 @@ let introCaseAssumsThen tac ba = List.flatten (List.map (function b -> if b then [false;true] else [false]) ba.branchsign) - in + in let n1 = List.length case_thin_sign in let n2 = List.length ba.branchnames in let (l1,l2),l3 = if n1 < n2 then list_chop n1 ba.branchnames, [] - else + else (ba.branchnames, []), if n1 > n2 then snd (list_chop n2 case_thin_sign) else [] in let introCaseAssums = @@ -75,9 +75,9 @@ let elimHypThen tac id gl = elimination_then tac ([],[]) (mkVar id) gl let rec general_decompose_on_hyp recognizer = - ifOnHyp recognizer (general_decompose recognizer) (fun _ -> tclIDTAC) + ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> tclIDTAC) -and general_decompose recognizer id = +and general_decompose_aux recognizer id = elimHypThen (introElimAssumsThen (fun bas -> @@ -93,12 +93,12 @@ and general_decompose recognizer id = 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) +let general_decompose recognizer c gl = + let typc = pf_type_of gl c in + tclTHENSV (cut typc) [| tclTHEN (intro_using tmphyp_name) - (onLastHyp - (ifOnHyp recognizer (general_decompose recognizer) + (onLastHypId + (ifOnHyp recognizer (general_decompose_aux recognizer) (fun id -> clear [id]))); exact_no_check c |] gl @@ -110,7 +110,7 @@ let head_in gls indl t = else extract_mrectype t in List.mem ity indl with Not_found -> false - + let inductive_of = function | IndRef ity -> ity | r -> @@ -118,34 +118,34 @@ let inductive_of = function (Printer.pr_global r ++ str " is not an inductive type.") let decompose_these c l gls = - let indl = (*List.map inductive_of*) l in + let indl = (*List.map inductive_of*) l in general_decompose (fun (_,t) -> head_in gls indl t) c gls let decompose_nonrec c gls = - general_decompose + general_decompose (fun (_,t) -> is_non_recursive_type t) c gls -let decompose_and c gls = - general_decompose +let decompose_and c gls = + general_decompose (fun (_,t) -> is_record t) c gls -let decompose_or c gls = - general_decompose +let decompose_or c gls = + general_decompose (fun (_,t) -> is_disjunction t) c gls let inj_open c = (Evd.empty,c) let h_decompose l c = - Refiner.abstract_tactic (TacDecompose (l,inj_open c)) (decompose_these c l) + Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l) let h_decompose_or c = - Refiner.abstract_tactic (TacDecomposeOr (inj_open c)) (decompose_or c) + Refiner.abstract_tactic (TacDecomposeOr c) (decompose_or c) let h_decompose_and c = - Refiner.abstract_tactic (TacDecomposeAnd (inj_open c)) (decompose_and c) + Refiner.abstract_tactic (TacDecomposeAnd c) (decompose_and c) (* The tactic Double performs a double induction *) @@ -153,17 +153,17 @@ let simple_elimination c gls = simple_elimination_then (fun _ -> tclIDTAC) c gls let induction_trailer abs_i abs_j bargs = - tclTHEN + tclTHEN (tclDO (abs_j - abs_i) intro) - (onLastHyp + (onLastHypId (fun id gls -> let idty = pf_type_of gls (mkVar id) in let fvty = global_vars (pf_env gls) idty in let possible_bring_hyps = - (List.tl (nLastHyps (abs_j - abs_i) gls)) @ bargs.assums + (List.tl (nLastDecls (abs_j - abs_i) gls)) @ bargs.assums in let (hyps,_) = - List.fold_left + List.fold_left (fun (bring_ids,leave_ids) (cid,_,cidty as d) -> if not (List.mem cid leave_ids) then (d::bring_ids,leave_ids) @@ -172,7 +172,7 @@ let induction_trailer abs_i abs_j bargs = in let ids = List.rev (ids_of_named_context hyps) in (tclTHENSEQ - [bring_hyps hyps; tclTRY (clear ids); + [bring_hyps hyps; tclTRY (clear ids); simple_elimination (mkVar id)]) gls)) @@ -184,7 +184,7 @@ let double_ind h1 h2 gls = if abs_i > abs_j then (abs_j,abs_i) else error "Both hypotheses are the same." in (tclTHEN (tclDO abs_i intro) - (onLastHyp + (onLastHypId (fun id -> elimination_then (introElimAssumsThen (induction_trailer abs_i abs_j)) diff --git a/tactics/elim.mli b/tactics/elim.mli index cbbf2f83..25ae0700 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: elim.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names @@ -23,7 +23,7 @@ val introElimAssumsThen : (branch_assumptions -> tactic) -> branch_args -> tactic val introCaseAssumsThen : - (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) -> + (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) -> branch_args -> tactic val general_decompose : (identifier * constr -> bool) -> constr -> tactic diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml new file mode 100644 index 00000000..e3f29fe5 --- /dev/null +++ b/tactics/elimschemes.ml @@ -0,0 +1,126 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +(* Created by Hugo Herbelin from contents related to inductive schemes + initially developed by Christine Paulin (induction schemes), Vincent + Siles (decidable equality and boolean equality) and Matthieu Sozeau + (combined scheme) in file command.ml, Sep 2009 *) + +(* This file builds schemes related to case analysis and recursion schemes *) + +open Term +open Indrec +open Declarations +open Typeops +open Termops +open Ind_tables + +(* Induction/recursion schemes *) + +let optimize_non_type_induction_scheme kind dep sort ind = + if check_scheme kind ind then + (* in case the inductive has a type elimination, generates only one + induction scheme, the other ones share the same code with the + apropriate type *) + let cte = find_scheme kind ind in + let c = mkConst cte in + let t = type_of_constant (Global.env()) cte in + let (mib,mip) = Global.lookup_inductive ind in + let npars = + (* if a constructor of [ind] contains a recursive call, the scheme + is generalized only wrt recursively uniform parameters *) + if (Inductiveops.mis_is_recursive_subset [snd ind] mip.mind_recargs) + then + mib.mind_nparams_rec + else + mib.mind_nparams in + snd (weaken_sort_scheme (new_sort_in_family sort) npars c t) + else + build_induction_scheme (Global.env()) Evd.empty ind dep sort + +let build_induction_scheme_in_type dep sort ind = + build_induction_scheme (Global.env()) Evd.empty ind dep sort + +let rect_scheme_kind_from_type = + declare_individual_scheme_object "_rect_nodep" + (build_induction_scheme_in_type false InType) + +let rect_scheme_kind_from_prop = + declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" + (build_induction_scheme_in_type false InType) + +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) + +let ind_scheme_kind_from_type = + declare_individual_scheme_object "_ind_nodep" + (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InProp) + +let ind_scheme_kind_from_prop = + declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" + (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InProp) + +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) + +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 case_scheme_kind_from_type = + declare_individual_scheme_object "_case_nodep" + (build_case_analysis_scheme_in_type false InType) + +let case_scheme_kind_from_prop = + declare_individual_scheme_object "_case" ~aux:"_case_from_prop" + (build_case_analysis_scheme_in_type false InType) + +let case_dep_scheme_kind_from_type = + declare_individual_scheme_object "_case" ~aux:"_case_from_type" + (build_case_analysis_scheme_in_type true InType) + +let case_dep_scheme_kind_from_type_in_prop = + declare_individual_scheme_object "_casep_dep" + (build_case_analysis_scheme_in_type true InProp) + +let case_dep_scheme_kind_from_prop = + declare_individual_scheme_object "_case_dep" + (build_case_analysis_scheme_in_type true InType) + +let case_dep_scheme_kind_from_prop_in_prop = + declare_individual_scheme_object "_casep" + (build_case_analysis_scheme_in_type true InProp) diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli new file mode 100644 index 00000000..fecf3e60 --- /dev/null +++ b/tactics/elimschemes.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +open Ind_tables + +(* Induction/recursion schemes *) + +val rect_scheme_kind_from_prop : individual scheme_kind +val ind_scheme_kind_from_prop : individual scheme_kind +val rec_scheme_kind_from_prop : individual scheme_kind +val rect_dep_scheme_kind_from_type : individual scheme_kind +val ind_dep_scheme_kind_from_type : individual scheme_kind +val rec_dep_scheme_kind_from_type : individual scheme_kind + + +(* Case analysis schemes *) + +val case_scheme_kind_from_type : individual scheme_kind +val case_scheme_kind_from_prop : individual scheme_kind +val case_dep_scheme_kind_from_type : individual scheme_kind +val case_dep_scheme_kind_from_type_in_prop : individual scheme_kind +val case_dep_scheme_kind_from_prop : individual scheme_kind +val case_dep_scheme_kind_from_prop_in_prop : individual scheme_kind diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4 index 41f85fa3..0d1699b1 100644 --- a/tactics/eqdecide.ml4 +++ b/tactics/eqdecide.ml4 @@ -14,11 +14,11 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: eqdecide.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id$ *) open Util open Names -open Nameops +open Namegen open Term open Declarations open Tactics @@ -49,41 +49,41 @@ open Coqlib then analyse one by one the corresponding pairs of arguments. If they are equal, rewrite one into the other. If they are not, derive a contradiction from the injectiveness of the - constructor. - 4. Once all the arguments have been rewritten, solve the remaining half + constructor. + 4. Once all the arguments have been rewritten, solve the remaining half of the disjunction by reflexivity. Eduardo Gimenez (30/3/98). *) -let clear_last = (tclLAST_HYP (fun c -> (clear [destVar c]))) +let clear_last = (onLastHyp (fun c -> (clear [destVar c]))) -let choose_eq eqonleft = +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 = +let mkBranches c1 c2 = tclTHENSEQ [generalize [c2]; h_simplest_elim c1; intros; - tclLAST_HYP h_simplest_case; + onLastHyp h_simplest_case; clear_last; intros] -let solveNoteqBranch side = +let solveNoteqBranch side = tclTHEN (choose_noteq side) - (tclTHEN (intro_force true) - (onLastHyp (fun id -> Extratactics.h_discrHyp id))) + (tclTHEN introf + (onLastHypId (fun id -> Extratactics.h_discrHyp id))) let h_solveNoteqBranch side = - Refiner.abstract_extended_tactic "solveNoteqBranch" [] + Refiner.abstract_extended_tactic "solveNoteqBranch" [] (solveNoteqBranch side) (* Constructs the type {c1=c2}+{~c1=c2} *) -let mkDecideEqGoal eqonleft op rectype c1 c2 g = +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 |]) @@ -92,24 +92,24 @@ let mkDecideEqGoal eqonleft op rectype c1 c2 g = (* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) -let mkGenDecideEqGoal rectype g = - let hypnames = pf_ids_of_hyps g in +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 + (mkNamedProd xname rectype + (mkNamedProd yname rectype (mkDecideEqGoal true (build_coq_sumbool ()) rectype (mkVar xname) (mkVar yname) g))) -let eqCase tac = - (tclTHEN intro - (tclTHEN (tclLAST_HYP Equality.rewriteLR) - (tclTHEN clear_last +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 + let absurd = id_of_string "absurd" in (tclTHEN (intro_using diseq) (tclTHEN (choose_noteq eqonleft) (tclTHEN red_in_concl @@ -118,11 +118,11 @@ let diseqCase eqonleft = (tclTHEN (Extratactics.h_injHyp absurd) (full_trivial []))))))) -let solveArg eqonleft op a1 a2 tac g = +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] + 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 @@ -133,8 +133,8 @@ let solveEqBranch rectype g = 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 + 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!" @@ -163,20 +163,20 @@ let decideGralEquality g = let decideEqualityGoal = tclTHEN intros decideGralEquality -let decideEquality c1 c2 g = - let rectype = (pf_type_of g c1) in - let decide = mkGenDecideEqGoal rectype g in +let decideEquality c1 c2 g = + let rectype = (pf_type_of g c1) in + let decide = mkGenDecideEqGoal rectype g in (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) g (* The tactic Compare *) -let compare c1 c2 g = +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 (tclLAST_HYP simplest_case) + let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in + (tclTHENS (cut decide) + [(tclTHEN intro + (tclTHEN (onLastHyp simplest_case) clear_last)); decideEquality c1 c2]) g diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml new file mode 100644 index 00000000..236eff72 --- /dev/null +++ b/tactics/eqschemes.ml @@ -0,0 +1,741 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id$ *) + +(* File created by Hugo Herbelin, Nov 2009 *) + +(* This file builds schemes related to equality inductive types, + especially for dependent rewrite, rewriting on arbitrary equality + types and congruence on arbitrary equality types *) + +(* However, the choices made lack uniformity, as we have to make a + compromise between several constraints and ideal requirements: + + - Having the extended schemes working conservatively over the + existing non-dependent schemes eq_rect and eq_rect_r. There is in + particular a problem with the dependent rewriting schemes in + hypotheses for which the inductive types cannot be in last + position of the scheme as it is the general rule in Coq. This has + an effect on the order of generated goals (side-conditions of the + lemma after or before the main goal). The non-dependent case can be + fixed but to the price of a lost of uniformity wrt side-conditions + in the dependent and non-dependent cases. + + - Having schemes general enough to support non-symmetric equality + type like eq_true. + + - Having schemes that avoid introducing beta-expansions blocked by + "match" so as to please the guard condition, but this introduces + some tricky things involving involutivity of symmetry that I + don't how to avoid. The result below is a compromise with + dependent left-to-right rewriting in conclusion (l2r_dep) using + the tricky involutivity of symmetry and dependent left-to-right + rewriting in hypotheses (r2l_forward_dep), that one wants to be + used for non-symmetric equality and that introduces blocked + beta-expansions. + + One may wonder whether these extensions are worth to be done + regarding the price we have to pay and regarding the rare + situations where they are needed. However, I believe it meets a + natural expectation of the user. +*) + +open Util +open Names +open Term +open Declarations +open Environ +open Inductive +open Termops +open Namegen +open Inductiveops +open Ind_tables +open Indrec + +let hid = id_of_string "H" +let xid = id_of_string "X" +let default_id_of_sort = function InProp | InSet -> hid | InType -> xid +let fresh env id = next_global_ident_away id [] + +let build_dependent_inductive ind (mib,mip) = + let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + applist + (mkInd ind, + extended_rel_list mip.mind_nrealargs_ctxt mib.mind_params_ctxt + @ extended_rel_list 0 realargs) + +let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn ~init:c s +let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn ~init:c s +let my_it_mkLambda_or_LetIn_name s c = + it_mkLambda_or_LetIn_name (Global.env()) c s + +let get_coq_eq () = + try + let eq = Libnames.destIndRef Coqlib.glob_eq in + let _ = Global.lookup_inductive eq in + (* Do not force the lazy if they are not defined *) + mkInd eq, Coqlib.build_coq_eq_refl () + with Not_found -> + error "eq not found." + +(**********************************************************************) +(* Check if an inductive type [ind] has the form *) +(* *) +(* I q1..qm,p1..pn a1..an with one constructor *) +(* C : I q1..qm,p1..pn p1..pn *) +(* *) +(* in which case, a symmetry lemma is definable *) +(**********************************************************************) + +let get_sym_eq_data env ind = + 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 + 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 + 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 + error "Constructor must have no arguments"; (* This can be relaxed... *) + 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 paramsctxt1,_ = + list_chop (mib.mind_nparams-mip.mind_nrealargs) mib.mind_params_ctxt in + if 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) + +(**********************************************************************) +(* Check if an inductive type [ind] has the form *) +(* *) +(* I q1..qm a1..an with one constructor *) +(* C : I q1..qm b1..bn *) +(* *) +(* in which case it expresses the equalities ai=bi, but not in a way *) +(* such that symmetry is a priori definable *) +(**********************************************************************) + +let get_non_sym_eq_data env ind = + 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 + 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 + 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 + error "Constructor must have no arguments"; + let _,constrargs = list_chop mib.mind_nparams constrargs in + (specif,constrargs,realsign,mip.mind_nrealargs) + +(**********************************************************************) +(* Build the symmetry lemma associated to an inductive type *) +(* I q1..qm,p1..pn a1..an with one constructor *) +(* C : I q1..qm,p1..pn p1..pn *) +(* *) +(* sym := fun q1..qn p1..pn a1..an (H:I q1..qm p1..pn a1..an) => *) +(* match H in I _.._ a1..an return I q1..qm a1..an p1..pn with *) +(* C => C *) +(* end *) +(* : forall q1..qm p1..pn a1..an I q1..qm p1..pn a1..an -> *) +(* I q1..qm a1..an p1..pn *) +(* *) +(**********************************************************************) + +let build_sym_scheme env ind = + let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = + get_sym_eq_data env ind in + let cstr n = + mkApp (mkConstruct(ind,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 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 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 + [extended_rel_vect (3*nrealargs+2) paramsctxt1; + rel_vect 1 nrealargs; + rel_vect (2*nrealargs+2) nrealargs])), + mkRel 1 (* varH *), + [|cstr (nrealargs+1)|])))) + +let sym_scheme_kind = + declare_individual_scheme_object "_sym" + (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind) + +(**********************************************************************) +(* Build the involutivity of symmetry for an inductive type *) +(* I q1..qm,p1..pn a1..an with one constructor *) +(* C : I q1..qm,p1..pn p1..pn *) +(* *) +(* inv := fun q1..qn p1..pn a1..an (H:I q1..qm p1..pn a1..an) => *) +(* match H in I _.._ a1..an return *) +(* sym q1..qm p1..pn a1..an (sym q1..qm a1..an p1..pn H) = H *) +(* with *) +(* C => refl_equal C *) +(* end *) +(* : forall q1..qm p1..pn a1..an (H:I q1..qm a1..an p1..pn), *) +(* sym q1..qm p1..pn a1..an (sym q1..qm a1..an p1..pn H) = H *) +(* *) +(**********************************************************************) + +let build_sym_involutive_scheme env ind = + 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 + 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_C = + mkApp + (mkInd ind, 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 sym_involutive_scheme_kind = + declare_individual_scheme_object "_sym_involutive" + (fun ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) + +(**********************************************************************) +(* Build the left-to-right rewriting lemma for conclusion associated *) +(* to an inductive type I q1..qm,p1..pn a1..an with one constructor *) +(* C : I q1..qm,p1..pn p1..pn *) +(* (symmetric equality in non-dependent and dependent cases) *) +(* *) +(* We could have defined the scheme in one match over a generalized *) +(* type but this behaves badly wrt the guard condition, so we use *) +(* symmetry instead; with commutative-cuts-aware guard condition a *) +(* proof in the style of l2r_forward is also possible (see below) *) +(* *) +(* rew := fun q1..qm p1..pn a1..an *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind) *) +(* (HC:P a1..an C) *) +(* (H:I q1..qm p1..pn a1..an) => *) +(* match sym_involutive q1..qm p1..pn a1..an H as Heq *) +(* in _ = H return P p1..pn H *) +(* with *) +(* refl => *) +(* match sym q1..qm p1..pn a1..an H as H *) +(* in I _.._ p1..pn *) +(* return P p1..pn (sym q1..qm a1..an p1..pn H) *) +(* with *) +(* C => HC *) +(* end *) +(* end *) +(* : forall q1..qn p1..pn a1..an *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind), *) +(* P a1..an C -> *) +(* forall (H:I q1..qm p1..pn a1..an), P p1..pn H *) +(* *) +(* where A1..An are the common types of p1..pn and a1..an *) +(* *) +(* Note: the symmetry is needed in the dependent case since the *) +(* dependency is on the inner arguments (the indices in C) and these *) +(* inner arguments need to be visible as parameters to be able to *) +(* abstract over them in P. *) +(**********************************************************************) + +(**********************************************************************) +(* For information, the alternative proof of dependent l2r_rew scheme *) +(* that would use commutative cuts is the following *) +(* *) +(* rew := fun q1..qm p1..pn a1..an *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind) *) +(* (HC:P a1..an C) *) +(* (H:I q1..qm p1..pn a1..an) => *) +(* match H in I .._.. a1..an return *) +(* forall p1..pn, I q1..qm p1..pn a1..an -> kind), *) +(* P a1..an C -> P p1..pn H *) +(* with *) +(* C => fun P HC => HC *) +(* end P HC *) +(* : forall q1..qn p1..pn a1..an *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind), *) +(* P a1..an C -> *) +(* forall (H:I q1..qm p1..pn a1..an), P p1..pn H *) +(* *) +(**********************************************************************) + +let build_l2r_rew_scheme dep env ind kind = + 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 + let cstr n p = + mkApp (mkConstruct(ind,1), + Array.concat [extended_rel_vect n paramsctxt1; + rel_vect p nrealargs]) in + let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let varHC = fresh env (id_of_string "HC") in + let varP = fresh env (id_of_string "P") in + let applied_ind = build_dependent_inductive ind specif in + let applied_ind_P = + mkApp (mkInd ind, 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 + [extended_rel_vect (3*nrealargs+3) paramsctxt1; + rel_vect (nrealargs+3) nrealargs; + rel_vect 0 nrealargs]) in + let realsign_P = lift_rel_context nrealargs realsign in + let realsign_ind_P = + name_context env ((Name varH,None,applied_ind_P)::realsign_P) in + let realsign_ind_G = + name_context env ((Name varH,None,applied_ind_G):: + lift_rel_context (nrealargs+3) realsign) in + let applied_sym_C n = + mkApp(sym, + Array.append (extended_rel_vect n mip.mind_arity_ctxt) [|mkVar varH|]) in + let applied_sym_G = + mkApp(sym, + Array.concat [extended_rel_vect (nrealargs*3+4) paramsctxt1; + rel_vect (nrealargs+4) nrealargs; + rel_vect 1 nrealargs; + [|mkRel 1|]]) in + let s = mkSort (new_sort_in_family kind) in + let ci = make_case_info (Global.env()) ind RegularStyle in + let cieq = make_case_info (Global.env()) (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 + let applied_PG = + mkApp (mkVar varP,Array.append (rel_vect 1 nrealargs) + (if dep then [|applied_sym_G|] else [||])) in + let applied_PR = + mkApp (mkVar varP,Array.append (rel_vect (nrealargs+5) nrealargs) + (if dep then [|mkRel 2|] else [||])) in + let applied_sym_sym = + mkApp (sym,Array.concat + [extended_rel_vect (2*nrealargs+4) paramsctxt1; + rel_vect 4 nrealargs; + rel_vect (nrealargs+4) nrealargs; + [|mkApp (sym,Array.concat + [extended_rel_vect (2*nrealargs+4) paramsctxt1; + rel_vect (nrealargs+4) nrealargs; + rel_vect 4 nrealargs; + [|mkRel 2|]])|]]) in + let main_body = + mkCase (ci, + my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, + applied_sym_C 3, + [|mkVar varHC|]) in + (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + (my_it_mkLambda_or_LetIn_name realsign + (mkNamedLambda varP + (my_it_mkProd_or_LetIn (if dep then realsign_ind_P else realsign_P) s) + (mkNamedLambda varHC applied_PC + (mkNamedLambda varH (lift 2 applied_ind) + (if dep then (* we need a coercion *) + mkCase (cieq, + mkLambda (Name varH,lift 3 applied_ind, + mkLambda (Anonymous, + mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), + applied_PR)), + mkApp (sym_involutive, + Array.append (extended_rel_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]), + [|main_body|]) + else + main_body)))))) + +(**********************************************************************) +(* Build the left-to-right rewriting lemma for hypotheses associated *) +(* to an inductive type I q1..qm,p1..pn a1..an with one constructor *) +(* C : I q1..qm,p1..pn p1..pn *) +(* (symmetric equality in non dependent and dependent cases) *) +(* *) +(* rew := fun q1..qm p1..pn a1..an (H:I q1..qm p1..pn a1..an) *) +(* match H in I _.._ a1..an *) +(* return forall *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an -> kind) *) +(* (HC:P p1..pn H) => *) +(* P a1..an C *) +(* with *) +(* C => fun P HC => HC *) +(* end *) +(* : forall q1..qm p1..pn a1..an *) +(* (H:I q1..qm p1..pn a1..an) *) +(* (P:forall p1..pn, I q1..qm p1..pn a1..an ->kind), *) +(* P p1..pn H -> P a1..an C *) +(* *) +(* Note: the symmetry is needed in the dependent case since the *) +(* dependency is on the inner arguments (the indices in C) and these *) +(* inner arguments need to be visible as parameters to be able to *) +(* abstract over them in P. *) +(**********************************************************************) + +let build_l2r_forward_rew_scheme dep env ind kind = + let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = + get_sym_eq_data env ind in + let cstr n p = + mkApp (mkConstruct(ind,1), + Array.concat [extended_rel_vect n paramsctxt1; + rel_vect p nrealargs]) in + let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let varHC = fresh env (id_of_string "HC") in + let varP = fresh env (id_of_string "P") in + let applied_ind = build_dependent_inductive ind specif in + let applied_ind_P = + mkApp (mkInd ind, 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 + [extended_rel_vect (3*nrealargs+1) paramsctxt1; + rel_vect 0 nrealargs; + rel_vect (2*nrealargs+1) nrealargs]) in + let realsign_P n = lift_rel_context (nrealargs*n+n) realsign in + let realsign_ind = + 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 ci = make_case_info (Global.env()) ind RegularStyle in + let applied_PC = + mkApp (mkVar varP,Array.append + (rel_vect (nrealargs*2+3) nrealargs) + (if dep then [|mkRel 2|] else [||])) in + let applied_PC' = + mkApp (mkVar varP,Array.append + (rel_vect (nrealargs+2) nrealargs) + (if dep then [|cstr (2*nrealargs+2) (nrealargs+2)|] + else [||])) in + let applied_PG = + mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs) + (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in + (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + (my_it_mkLambda_or_LetIn_name realsign + (mkNamedLambda varH applied_ind + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkNamedProd varP + (my_it_mkProd_or_LetIn + (if dep then realsign_ind_P 2 applied_ind_P else realsign_P 2) s) + (mkNamedProd varHC applied_PC applied_PG)), + (mkVar varH), + [|mkNamedLambda varP + (my_it_mkProd_or_LetIn + (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) + (mkNamedLambda varHC applied_PC' + (mkVar varHC))|]))))) + +(**********************************************************************) +(* Build the right-to-left rewriting lemma for hypotheses associated *) +(* to an inductive type I q1..qm a1..an with one constructor *) +(* C : I q1..qm b1..bn *) +(* (arbitrary equality in non-dependent and dependent cases) *) +(* *) +(* rew := fun q1..qm a1..an (H:I q1..qm a1..an) *) +(* (P:forall a1..an, I q1..qm a1..an -> kind) *) +(* (HC:P a1..an H) => *) +(* match H in I _.._ a1..an return P a1..an H -> P b1..bn C *) +(* with *) +(* C => fun x => x *) +(* end HC *) +(* : forall q1..pm a1..an (H:I q1..qm a1..an) *) +(* (P:forall a1..an, I q1..qm a1..an -> kind), *) +(* P a1..an H -> P b1..bn C *) +(* *) +(* Note that the dependent elimination here is not a dependency *) +(* in the conclusion of the scheme but a dependency in the premise of *) +(* the scheme. This is unfortunately incompatible with the standard *) +(* pattern for schemes in Coq which expects that the eliminated *) +(* object is the last premise of the scheme. We then have no choice *) +(* than following the more liberal pattern of having the eliminated *) +(* object coming before the premises. *) +(* *) +(* Note that in the non-dependent case, this scheme (up to the order *) +(* of premises) generalizes the (backward) l2r scheme above: same *) +(* 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 cstr n = + mkApp (mkConstruct(ind,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 realsign_ind = + name_context env ((Name varH,None,applied_ind)::realsign) in + let s = mkSort (new_sort_in_family kind) 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 + let applied_PG = + 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 + (my_it_mkLambda_or_LetIn_name realsign_ind + (mkNamedLambda varP + (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1) + (if dep then realsign_ind else realsign)) s) + (mkNamedLambda varHC (lift 1 applied_PG) + (mkApp + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+3) realsign_ind) + (mkArrow applied_PG (lift (2*nrealargs+5) applied_PC)), + mkRel 3 (* varH *), + [|mkLambda + (Name varHC, + lift (nrealargs+3) applied_PC, + mkRel 1)|]), + [|mkVar varHC|])))))) + +(**********************************************************************) +(* This function "repairs" the non-dependent r2l forward rewriting *) +(* scheme by making it comply with the standard pattern of schemes *) +(* in Coq. Otherwise said, it turns a scheme of type *) +(* *) +(* forall q1..pm a1..an, I q1..qm a1..an -> *) +(* forall (P: forall a1..an, kind), *) +(* P a1..an -> P b1..bn *) +(* *) +(* into a scheme of type *) +(* *) +(* forall q1..pm (P:forall a1..an, kind), *) +(* P a1..an -> forall a1..an, I q1..qm a1..an -> P b1..bn *) +(* *) +(**********************************************************************) + +let fix_r2l_forward_rew_scheme c = + 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 -> + 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) + (mkLambda_or_LetIn (map_rel_declaration (lift 2) ind) + (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" + +(**********************************************************************) +(* Build the right-to-left rewriting lemma for conclusion associated *) +(* to an inductive type I q1..qm a1..an with one constructor *) +(* C : I q1..qm b1..bn *) +(* (arbitrary equality in non-dependent and dependent case) *) +(* *) +(* This is actually the standard case analysis scheme *) +(* *) +(* rew := fun q1..qm a1..an *) +(* (P:forall a1..an, I q1..qm a1..an -> kind) *) +(* (H:I q1..qm a1..an) *) +(* (HC:P b1..bn C) => *) +(* match H in I _.._ a1..an return P a1..an H with *) +(* C => HC *) +(* end *) +(* : forall q1..pm a1..an *) +(* (P:forall a1..an, I q1..qm a1..an -> kind) *) +(* (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 + +(**********************************************************************) +(* Register the rewriting schemes *) +(**********************************************************************) + +(**********************************************************************) +(* Dependent rewrite from left-to-right in conclusion *) +(* (symmetrical equality type only) *) +(* Gamma |- P p1..pn H ==> Gamma |- P a1..an C *) +(* with H:I p1..pn a1..an in Gamma *) +(**********************************************************************) +let rew_l2r_dep_scheme_kind = + declare_individual_scheme_object "_rew_r_dep" + (fun ind -> build_l2r_rew_scheme true (Global.env()) ind InType) + +(**********************************************************************) +(* Dependent rewrite from right-to-left in conclusion *) +(* Gamma |- P a1..an H ==> Gamma |- P b1..bn C *) +(* with H:I a1..an in Gamma (non symmetric case) *) +(* or H:I b1..bn a1..an in Gamma (symmetric case) *) +(**********************************************************************) +let rew_r2l_dep_scheme_kind = + declare_individual_scheme_object "_rew_dep" + (fun ind -> build_r2l_rew_scheme true (Global.env()) ind InType) + +(**********************************************************************) +(* Dependent rewrite from right-to-left in hypotheses *) +(* Gamma, P a1..an H |- D ==> Gamma, P b1..bn C |- D *) +(* with H:I a1..an in Gamma (non symmetric case) *) +(* or H:I b1..bn a1..an in Gamma (symmetric case) *) +(**********************************************************************) +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) + +(**********************************************************************) +(* Dependent rewrite from left-to-right in hypotheses *) +(* (symmetrical equality type only) *) +(* Gamma, P p1..pn H |- D ==> Gamma, P a1..an C |- D *) +(* with H:I p1..pn a1..an in Gamma *) +(**********************************************************************) +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) + +(**********************************************************************) +(* Non-dependent rewrite from either left-to-right in conclusion or *) +(* right-to-left in hypotheses: both l2r_rew and r2l_forward_rew are *) +(* potential candidates. However r2l_forward_rew introduces a blocked *) +(* beta-expansion that blocks in turn the guard condition if this *) +(* one does not support commutative cuts while l2r_rew does not *) +(* support non symmetrical equalities, so... *) +(**********************************************************************) + +(**********************************************************************) +(* ... we use l2r_rew for the symmetrical case: *) +(**********************************************************************) +let rew_l2r_scheme_kind = + declare_individual_scheme_object "_rew_r" + (fun ind -> build_l2r_rew_scheme false (Global.env()) ind InType) + +(**********************************************************************) +(* ... and r2l_forward_rew for the non-symmetrical case, even though *) +(* it may break the guard condition. Moreover, its standard form *) +(* needs the inductive hypothesis not in last position what breaks *) +(* the order of goals and need a fix: *) +(**********************************************************************) +let rew_asym_scheme_kind = + declare_individual_scheme_object "_rew_r_asym" + (fun ind -> fix_r2l_forward_rew_scheme + (build_r2l_forward_rew_scheme false (Global.env()) ind InType)) + +(**********************************************************************) +(* Non-dependent rewrite from either right-to-left in conclusion or *) +(* left-to-right in hypotheses: both r2l_rew and l2r_forward_rew but *) +(* since r2l_rew works in the non-symmetric case as well as without *) +(* introducing commutative cuts, we adopt it *) +(**********************************************************************) +let rew_r2l_scheme_kind = + declare_individual_scheme_object "_rew" + (fun ind -> build_r2l_rew_scheme false (Global.env()) ind InType) + +(* End of rewriting schemes *) + +(**********************************************************************) +(* Build the congruence lemma associated to an inductive type *) +(* I p1..pn a with one constructor C : I q1..qn b *) +(* *) +(* congr := fun p1..pn (B:Type) (f:A->B) a (H:I p1..pn a) => *) +(* match H in I _.._ a' return f b = f a' with *) +(* C => eq_refl (f b) *) +(* end *) +(* : forall p1..pn (B:Type) (f:A->B) a, I p1..pn a -> f b = f a *) +(* *) +(* where A is the common type of a and b *) +(**********************************************************************) + +(* TODO: extend it to types with more than one index *) + +let build_congr env (eq,refl) ind = + 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 + error "Not an inductive type with a single constructor."; + if 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 + error "Inductive equalities with local definitions in arity not supported."; + let env_with_arity = push_rel_context mip.mind_arity_ctxt 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 + 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 ci = make_case_info (Global.env()) ind RegularStyle in + my_it_mkLambda_or_LetIn mib.mind_params_ctxt + (mkNamedLambda varB (new_Type ()) + (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 @ + extended_rel_list 0 realsign)) + (mkCase (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (mip.mind_nrealargs+3) realsign) + (mkLambda + (Anonymous, + applist + (mkInd ind, + extended_rel_list (2*mip.mind_nrealargs_ctxt+3) + mib.mind_params_ctxt + @ extended_rel_list 0 realsign), + mkApp (eq, + [|mkVar varB; + mkApp (mkVar varf, [|lift (2*mip.mind_nrealargs_ctxt+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|])|])|])))))) + +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) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli new file mode 100644 index 00000000..96196ac3 --- /dev/null +++ b/tactics/eqschemes.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id$ i*) + +(* This file builds schemes relative to equality inductive types *) + +open Names +open Term +open Environ +open Ind_tables + +(* Builds a left-to-right rewriting scheme for an equality type *) + +val rew_l2r_dep_scheme_kind : individual scheme_kind +val rew_l2r_scheme_kind : individual scheme_kind +val rew_r2l_forward_dep_scheme_kind : individual scheme_kind +val rew_l2r_forward_dep_scheme_kind : individual scheme_kind +val rew_r2l_dep_scheme_kind : individual scheme_kind +val rew_r2l_scheme_kind : individual scheme_kind +val rew_asym_scheme_kind : individual scheme_kind + +val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr +val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> constr +val build_r2l_forward_rew_scheme : + bool -> env -> inductive -> sorts_family -> constr +val build_l2r_forward_rew_scheme : + bool -> env -> inductive -> sorts_family -> constr + +(* Builds a symmetry scheme for a symmetrical equality type *) + +val build_sym_scheme : env -> inductive -> constr +val sym_scheme_kind : individual scheme_kind + +val build_sym_involutive_scheme : env -> inductive -> constr +val sym_involutive_scheme_kind : individual scheme_kind + +(* Builds a congruence scheme for an equality type *) + +val congr_scheme_kind : individual scheme_kind +val build_congr : env -> constr * constr -> inductive -> constr diff --git a/tactics/equality.ml b/tactics/equality.ml index bf199379..6522361e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: equality.ml 12886 2010-03-27 14:22:00Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -15,6 +15,7 @@ open Nameops open Univ open Term open Termops +open Namegen open Inductive open Inductiveops open Environ @@ -43,9 +44,36 @@ open Printer open Clenv open Clenvtac open Evd +open Ind_tables +open Eqschemes + +(* Options *) + +let discriminate_introduction = ref true + +let discr_do_intro () = + !discriminate_introduction && Flags.version_strictly_greater Flags.V8_2 + +open Goptions +let _ = + declare_bool_option + { optsync = true; + optname = "automatic introduction of hypotheses by discriminate"; + optkey = ["Discriminate";"Introduction"]; + optread = (fun () -> !discriminate_introduction); + optwrite = (:=) discriminate_introduction } (* Rewriting tactics *) +type dep_proof_flag = bool (* true = support rewriting dependent proofs *) + +type orientation = bool + +type conditions = + | Naive (* Only try the first occurence of the lemma (default) *) + | FirstSolved (* Use the first match whose side-conditions are solved *) + | AllMatches (* Rewrite all matches whose side-conditions are solved *) + (* Warning : rewriting from left to right only works if there exists in the context a theorem named <eqname>_<suffsort>_r with type (A:<sort>)(x:A)(P:A->Prop)(P x)->(y:A)(eqname A y x)->(P y). @@ -54,161 +82,264 @@ open Evd -- Eduardo (19/8/97) *) +let rewrite_unif_flags = { + Unification.modulo_conv_on_closed_terms = None; + Unification.use_metas_eagerly = true; + Unification.modulo_delta = empty_transparent_state; + Unification.resolve_evars = true; + Unification.use_evars_pattern_unification = true; +} + +let side_tac tac sidetac = + match sidetac with + | None -> tac + | Some sidetac -> tclTHENSFIRSTn tac [|tclIDTAC|] sidetac + +let instantiate_lemma_all env sigma gl c ty l l2r concl = + let 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 + let try_occ (evd', c') = + let cl' = {eqclause with evd = evd'} in + let mvs = clenv_dependent false cl' in + clenv_pose_metas_as_evars cl' mvs + in + let occs = + Unification.w_unify_to_subterm_all ~flags:rewrite_unif_flags env + ((if l2r then c1 else c2),concl) eqclause.evd + 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 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 + [eqclause] + +let rewrite_elim with_evars c e ?(allow_K=true) = + general_elim_clause_gen (elimination_clause_scheme with_evars allow_K) c e + +let rewrite_elim_in with_evars id c e = + general_elim_clause_gen (elimination_in_clause_scheme with_evars id) c e + (* Ad hoc asymmetric general_elim_clause *) -let general_elim_clause with_evars cls sigma c l elim = - try +let general_elim_clause with_evars cls rew elim = + try (match cls with | None -> - (* was tclWEAK_PROGRESS which only fails for tactics generating one + (* was tclWEAK_PROGRESS which only fails for tactics generating one subgoal and did not fail for useless conditional rewritings generating an extra condition *) - tclNOTSAMEGOAL (tclTHEN (Refiner.tclEVARS sigma) - (general_elim with_evars (c,l) elim ~allow_K:false)) - | Some id -> - tclTHEN (Refiner.tclEVARS sigma) (general_elim_in with_evars id (c,l) elim)) + tclNOTSAMEGOAL (rewrite_elim with_evars rew elim ~allow_K:false) + | Some id -> rewrite_elim_in with_evars id rew elim) with Pretype_errors.PretypeError (env, (Pretype_errors.NoOccurrenceFound (c', _))) -> raise (Pretype_errors.PretypeError (env, (Pretype_errors.NoOccurrenceFound (c', cls)))) - -(* The next function decides in particular whether to try a regular - rewrite or a setoid rewrite. - Approach is to break everything, if [eq] appears in head position - then regular rewrite else try setoid rewrite. - If occurrences are set, use setoid_rewrite. -*) -let general_setoid_rewrite_clause = ref (fun _ -> assert false) -let register_general_setoid_rewrite_clause = (:=) general_setoid_rewrite_clause +let general_elim_clause with_evars tac cls sigma c t l l2r elim gl = + let all, firstonly, tac = + match tac with + | None -> false, false, None + | Some (tac, Naive) -> false, false, Some tac + | 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) + (pf_env gl) sigma gl c t l l2r + (match cls with None -> pf_concl gl | Some id -> pf_get_hyp_typ gl id) + in + let try_clause c = + side_tac (tclTHEN (Refiner.tclEVARS c.evd) (general_elim_clause with_evars cls c elim)) tac + in + if firstonly then + tclFIRST (List.map try_clause cs) gl + else tclMAP try_clause cs gl + +(* The next function decides in particular whether to try a regular + rewrite or a generalized rewrite. + Approach is to break everything, if [eq] appears in head position + then regular rewrite else try general rewrite. + If occurrences are set, use general rewrite. +*) -let is_applied_setoid_relation = ref (fun _ -> false) -let register_is_applied_setoid_relation = (:=) is_applied_setoid_relation +let general_rewrite_clause = ref (fun _ -> assert false) +let register_general_rewrite_clause = (:=) general_rewrite_clause -let is_applied_relation t = - match kind_of_term t with - | App (c, args) when Array.length args >= 2 -> true - | _ -> false +let is_applied_rewrite_relation = ref (fun _ _ _ _ -> None) +let register_is_applied_rewrite_relation = (:=) is_applied_rewrite_relation (* find_elim determines which elimination principle is necessary to eliminate lbeq on sort_of_gl. *) -let find_elim hdcncl lft2rgt cls gl = - let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in - let hdcncls = string_of_inductive hdcncl ^ suffix in - let rwr_thm = if lft2rgt = (cls = None) then hdcncls^"_r" else hdcncls in - try pf_global gl (id_of_string rwr_thm) - with Not_found -> error ("Cannot find rewrite principle "^rwr_thm^".") - -let leibniz_rewrite_ebindings_clause cls lft2rgt sigma c l with_evars gl hdcncl = - let elim = find_elim hdcncl lft2rgt cls gl in - general_elim_clause with_evars cls sigma c l (elim,NoBindings) gl +let find_elim hdcncl lft2rgt dep cls args gl = + let inccl = (cls = None) in + if (hdcncl = constr_of_reference (Coqlib.glob_eq) || + hdcncl = constr_of_reference (Coqlib.glob_jmeq) && + pf_conv_x gl (List.nth args 0) (List.nth args 2)) && not dep + || Flags.version_less_or_equal Flags.V8_2 + then + (* use eq_rect, eq_rect_r, JMeq_rect, etc for compatibility *) + let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in + let hdcncls = string_of_inductive hdcncl ^ suffix in + let rwr_thm = if lft2rgt = Some (cls=None) then hdcncls^"_r" else hdcncls in + try pf_global gl (id_of_string rwr_thm) + with Not_found -> error ("Cannot find rewrite principle "^rwr_thm^".") + else + let scheme_name = match dep, lft2rgt, inccl with + (* Non dependent case with symmetric equality *) + | false, Some true, true | false, Some false, false -> rew_l2r_scheme_kind + | false, Some false, true | false, Some true, false -> rew_r2l_scheme_kind + (* Dependent case with symmetric equality *) + | true, Some true, true -> rew_l2r_dep_scheme_kind + | true, Some true, false -> rew_l2r_forward_dep_scheme_kind + | true, Some false, true -> rew_r2l_dep_scheme_kind + | true, Some false, false -> rew_r2l_forward_dep_scheme_kind + (* Non dependent case with non-symmetric rewriting lemma *) + | false, None, true -> rew_r2l_scheme_kind + | false, None, false -> rew_asym_scheme_kind + (* Dependent case with non-symmetric rewriting lemma *) + | true, None, true -> rew_r2l_dep_scheme_kind + | true, None, false -> rew_r2l_forward_dep_scheme_kind + in + match kind_of_term hdcncl with + | Ind ind -> mkConst (find_scheme scheme_name ind) + | _ -> assert false + +let type_of_clause gl = function + | None -> pf_concl gl + | Some id -> pf_get_hyp_typ gl id + +let leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars dep_proof_ok gl hdcncl = + let isatomic = isProd (whd_zeta hdcncl) in + let dep_fun = if isatomic then dependent else dependent_no_evar in + let dep = dep_proof_ok && dep_fun c (type_of_clause gl cls) in + let elim = find_elim hdcncl lft2rgt dep cls (snd (decompose_app t)) gl in + general_elim_clause with_evars tac cls sigma c t l + (match lft2rgt with None -> false | Some b -> b) + {elimindex = None; elimbody = (elim,NoBindings)} gl let adjust_rewriting_direction args lft2rgt = - if List.length args = 1 then + if List.length args = 1 then begin (* equality to a constant, like in eq_true *) (* more natural to see -> as the rewriting to the constant *) - not lft2rgt + if not lft2rgt then + error "Rewriting non-symmetric equality not allowed from right-to-left."; + None + end else (* other equality *) - lft2rgt + Some lft2rgt + +let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac) -let general_rewrite_ebindings_clause cls lft2rgt occs ((c,l) : open_constr with_bindings) with_evars gl = +(* Main function for dispatching which kind of rewriting it is about *) + +let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac + ((c,l) : constr with_bindings) with_evars gl = if occs <> all_occurrences then ( - !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl) + rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl) else let env = pf_env gl in - let sigma, c' = c in - let sigma = Evd.merge sigma (project gl) in - let ctype = get_type_of env sigma c' in - let rels, t = decompose_prod (whd_betaiotazeta sigma ctype) in + let sigma = project 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 rewrite *) + | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in - leibniz_rewrite_ebindings_clause cls lft2rgt sigma c' l with_evars gl hdcncl + leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c (it_mkProd_or_LetIn t rels) + l with_evars dep_proof_ok gl hdcncl | None -> - let env' = List.fold_left (fun env (n,t) -> push_rel (n, None, t) env) env rels in - let _,t' = splay_prod env' sigma t in (* Search for underlying eq *) - match match_with_equality_type t' with - | Some (hdcncl,args) -> (* Maybe a setoid relation with eq inside *) - let lft2rgt = adjust_rewriting_direction args lft2rgt in - if l = NoBindings && !is_applied_setoid_relation t then - !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl - else - (try leibniz_rewrite_ebindings_clause cls lft2rgt sigma c' l with_evars gl hdcncl - with e -> - try !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl - with _ -> raise e) - | None -> (* Can't be leibniz, try setoid *) - if l = NoBindings - then !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl - else error "The term provided does not end with an equation." - -let general_rewrite_ebindings = + try + rewrite_side_tac (!general_rewrite_clause cls + lft2rgt occs (c,l) ~new_goals:[]) tac gl + with 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) -> + let lft2rgt = adjust_rewriting_direction args lft2rgt in + leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c + (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars dep_proof_ok gl hdcncl + | None -> raise e + (* error "The provided term does not end with an equality or a declared rewrite relation." *) + +let general_rewrite_ebindings = general_rewrite_ebindings_clause None -let general_rewrite_bindings l2r occs (c,bl) = - general_rewrite_ebindings_clause None l2r occs (inj_open c,inj_ebindings bl) -let general_rewrite l2r occs c = - general_rewrite_bindings l2r occs (c,NoBindings) false +let general_rewrite_bindings l2r occs dep_proof_ok ?tac (c,bl) = + general_rewrite_ebindings_clause None l2r occs dep_proof_ok ?tac (c,bl) + +let general_rewrite l2r occs dep_proof_ok ?tac c = + general_rewrite_bindings l2r occs dep_proof_ok ?tac (c,NoBindings) false + +let general_rewrite_ebindings_in l2r occs dep_proof_ok ?tac id = + general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac + +let general_rewrite_bindings_in l2r occs dep_proof_ok ?tac id (c,bl) = + general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac (c,bl) -let general_rewrite_ebindings_in l2r occs id = - general_rewrite_ebindings_clause (Some id) l2r occs -let general_rewrite_bindings_in l2r occs id (c,bl) = - general_rewrite_ebindings_clause (Some id) l2r occs (inj_open c,inj_ebindings bl) -let general_rewrite_in l2r occs id c = - general_rewrite_ebindings_clause (Some id) l2r occs (inj_open c,NoBindings) +let general_rewrite_in l2r occs dep_proof_ok ?tac id c = + general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac (c,NoBindings) -let general_multi_rewrite l2r with_evars c cl = - let occs_of = on_snd (List.fold_left +let general_multi_rewrite l2r with_evars ?tac c cl = + let occs_of = on_snd (List.fold_left (fun acc -> function ArgArg x -> x :: acc | ArgVar _ -> acc) []) in - match cl.onhyps with - | Some l -> + match cl.onhyps with + | Some l -> (* If a precise list of locations is given, success is mandatory for each of these locations. *) - let rec do_hyps = function + let rec do_hyps = function | [] -> tclIDTAC - | ((occs,id),_) :: l -> + | ((occs,id),_) :: l -> tclTHENFIRST - (general_rewrite_ebindings_in l2r (occs_of occs) id c with_evars) + (general_rewrite_ebindings_in l2r (occs_of occs) true ?tac id c with_evars) (do_hyps l) - in + in if cl.concl_occs = no_occurrences_expr then do_hyps l else tclTHENFIRST - (general_rewrite_ebindings l2r (occs_of cl.concl_occs) c with_evars) + (general_rewrite_ebindings l2r (occs_of cl.concl_occs) 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 + | 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.") - | id :: l -> - tclIFTHENTRYELSEMUST - (general_rewrite_ebindings_in l2r all_occurrences id c with_evars) + | id :: l -> + tclIFTHENTRYELSEMUST + (general_rewrite_ebindings_in l2r all_occurrences true ?tac id c with_evars) (do_hyps_atleastonce l) - in - let do_hyps gl = + in + let do_hyps gl = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) - let ids = - let ids_in_c = Environ.global_vars_set (Global.env()) (snd (fst c)) in + let ids = + 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 - in + in if cl.concl_occs = no_occurrences_expr then do_hyps else - tclIFTHENTRYELSEMUST - (general_rewrite_ebindings l2r (occs_of cl.concl_occs) c with_evars) + tclIFTHENTRYELSEMUST + (general_rewrite_ebindings l2r (occs_of cl.concl_occs) true ?tac c with_evars) do_hyps -let general_multi_multi_rewrite with_evars l cl tac = - let do1 l2r c = - match tac with - None -> general_multi_rewrite l2r with_evars c cl - | Some tac -> tclTHENSFIRSTn (general_multi_rewrite l2r with_evars c cl) - [|tclIDTAC|] (tclCOMPLETE tac) - in - let rec doN l2r c = function +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 rec doN l2r c = function | Precisely n when n <= 0 -> tclIDTAC | Precisely 1 -> do1 l2r c | Precisely n -> tclTHENFIRST (do1 l2r c) (doN l2r c (Precisely (n-1))) @@ -216,62 +347,39 @@ let general_multi_multi_rewrite with_evars l cl tac = | RepeatPlus -> tclTHENFIRST (do1 l2r c) (doN l2r c RepeatStar) | UpTo n when n<=0 -> tclIDTAC | UpTo n -> tclTHENFIRST (tclTRY (do1 l2r c)) (doN l2r c (UpTo (n-1))) - in + in let rec loop = function | [] -> tclIDTAC | (l2r,m,c)::l -> tclTHENFIRST (doN l2r c m) (loop l) in loop l -(* Conditional rewriting, the success of a rewriting is related - to the resolution of the conditions by a given tactic *) - -let conditional_rewrite lft2rgt tac (c,bl) = - tclTHENSFIRSTn - (general_rewrite_ebindings lft2rgt all_occurrences (c,bl) false) - [|tclIDTAC|] (tclCOMPLETE tac) - -let rewriteLR_bindings = general_rewrite_bindings true all_occurrences -let rewriteRL_bindings = general_rewrite_bindings false all_occurrences - -let rewriteLR = general_rewrite true all_occurrences -let rewriteRL = general_rewrite false all_occurrences - -let rewriteLRin_bindings = general_rewrite_bindings_in true all_occurrences -let rewriteRLin_bindings = general_rewrite_bindings_in false all_occurrences - -let conditional_rewrite_in lft2rgt id tac (c,bl) = - tclTHENSFIRSTn - (general_rewrite_ebindings_in lft2rgt all_occurrences id (c,bl) false) - [|tclIDTAC|] (tclCOMPLETE tac) - -let rewriteRL_clause = function - | None -> rewriteRL_bindings - | Some id -> rewriteRLin_bindings id +let rewriteLR = general_rewrite true all_occurrences true +let rewriteRL = general_rewrite false all_occurrences true (* Replacing tactics *) (* eq,sym_eq : equality on Type and its symmetry theorem c2 c1 : 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 + tac : Used to prove the equality c1 = c2 gl : goal *) -let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = - let try_prove_eq = - match try_prove_eq_opt with +let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = + let try_prove_eq = + match try_prove_eq_opt with | None -> tclIDTAC | Some tac -> tclCOMPLETE tac in - let t1 = pf_apply get_type_of gl c1 + 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 let e = build_coq_eq () in - let sym = build_coq_sym_eq () in + let sym = build_coq_eq_sym () in let eq = applist (e, [t1;c1;c2]) in tclTHENS (assert_as false None eq) - [onLastHyp (fun id -> - tclTHEN - (tclTRY (general_multi_rewrite false false (inj_open (mkVar id),NoBindings) clause)) + [onLastHypId (fun id -> + tclTHEN + (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) (clear [id])); tclFIRST [assumption; @@ -281,7 +389,7 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = ] gl else error "Terms do not have convertible types." - + let replace c2 c1 gl = multi_replace onConcl c2 c1 false None gl @@ -291,7 +399,7 @@ let replace_by c2 c1 tac gl = multi_replace onConcl c2 c1 false (Some tac) gl let replace_in_by id c2 c1 tac gl = multi_replace (onHyp id) c2 c1 false (Some tac) gl -let replace_in_clause_maybe_by c2 c1 cl tac_opt gl = +let replace_in_clause_maybe_by c2 c1 cl tac_opt gl = multi_replace cl c2 c1 false tac_opt gl (* End of Eduardo's code. The rest of this file could be improved @@ -346,8 +454,8 @@ let find_positions env sigma t1 t2 = let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with - - | Construct sp1, Construct sp2 + + | Construct sp1, Construct sp2 when List.length args1 = mis_constructor_nargs_env env sp1 -> let sorts = list_intersect sorts (allowed_sorts env (fst sp1)) in @@ -365,14 +473,14 @@ let find_positions env sigma t1 t2 = else [] | _ -> - let t1_0 = applist (hd1,args1) + let t1_0 = applist (hd1,args1) and t2_0 = applist (hd2,args2) in - if is_conv env sigma t1_0 t2_0 then + 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 + if List.mem s sorts then [(List.rev posn,t1_0,t2_0)] else [] in try (* Rem: to allow injection on proofs objects, just add InProp *) Inr (findrec [InSet;InType] [] t1 t2) @@ -384,7 +492,7 @@ let discriminable env sigma t1 t2 = | Inl _ -> true | _ -> false -let injectable env sigma t1 t2 = +let injectable env sigma t1 t2 = match find_positions env sigma t1 t2 with | Inl _ | Inr [] -> false | Inr _ -> true @@ -458,7 +566,7 @@ let descend_then sigma env head dirn = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in - let ind,_ = dest_ind_family indf in + let ind,_ = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in @@ -499,13 +607,13 @@ let construct_discriminator sigma env dirn c sort = let IndType(indf,_) = try find_rectype env sigma (get_type_of env sigma c) with Not_found -> - (* one can find Rel(k) in case of dependent constructors - like T := c : (A:Set)A->T and a discrimination + (* one can find Rel(k) in case of dependent constructors + like T := c : (A:Set)A->T and a discrimination on (c bool true) = (c bool false) CP : changed assert false in a more informative error *) errorlabstrm "Equality.construct_discriminator" - (str "Cannot discriminate on inductive constructors with + (str "Cannot discriminate on inductive constructors with dependent types.") in let (ind,_) = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in @@ -520,7 +628,7 @@ let construct_discriminator sigma env dirn c sort = List.map build_branch(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 | ((sp,cnum),argnum)::l -> @@ -541,17 +649,17 @@ let rec build_discriminator sigma env dirn c sort = function *) let gen_absurdity id gl = - if is_empty_type (clause_type (onHyp id) gl) + if is_empty_type (pf_get_hyp_typ gl id) then simplest_elim (mkVar id) gl else - errorlabstrm "Equality.gen_absurdity" + errorlabstrm "Equality.gen_absurdity" (str "Not the negation of an equality.") (* Precondition: eq is leibniz equality - + returns ((eq_elim t t1 P i t2), absurd_term) - where P=[e:t]discriminator + where P=[e:t]discriminator absurd_term=False *) @@ -566,18 +674,17 @@ exception NotDiscriminable let eq_baseid = id_of_string "e" let apply_on_clause (f,t) clause = - let sigma = Evd.evars_of clause.evd in + let sigma = clause.evd in let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in - let argmv = + let argmv = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in clenv_fchain argmv f_clause clause -let discr_positions env sigma (lbeq,(t,t1,t2)) eq_clause cpath dirn sort = +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 eqn = mkApp(lbeq.eq,[|t;t1;t2|]) 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 @@ -585,16 +692,16 @@ let discr_positions env sigma (lbeq,(t,t1,t2)) eq_clause cpath dirn sort = 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) - [onLastHyp gen_absurdity; refine pf] + [onLastHypId gen_absurdity; refine pf] -let discrEq (lbeq,(t,t1,t2) as u) eq_clause gls = - let sigma = Evd.evars_of eq_clause.evd in +let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause gls = + let sigma = eq_clause.evd in let env = pf_env gls in match find_positions env sigma t1 t2 with | Inr _ -> errorlabstrm "discr" (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> - let sort = pf_apply get_type_of gls (pf_concl gls) in + 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 = @@ -603,39 +710,43 @@ let onEquality with_evars tac (c,lbindc) gls = let eq_clause = make_clenv_binding gls (c,t') lbindc in let eq_clause' = clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in - let eq = - try find_eq_data_decompose eqn - with PatternMatchingFailure -> - errorlabstrm "" (str"No primitive equality found.") in + let eq,eq_args = find_this_eq_data_decompose gls eqn in tclTHEN - (Refiner.tclEVARS (Evd.evars_of eq_clause'.evd)) - (tac eq eq_clause') gls + (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 - (onLastHyp (fun id -> + (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) gls - | _ -> + | _ -> errorlabstrm "" (str "Not a negated primitive equality.") let discrSimpleClause with_evars = function | None -> onNegatedEquality with_evars discrEq - | Some ((_,id),_) -> onEquality with_evars discrEq (mkVar id,NoBindings) + | Some id -> onEquality with_evars discrEq (mkVar id,NoBindings) let discr with_evars = onEquality with_evars discrEq -let discrClause with_evars = onClauses (discrSimpleClause with_evars) +let discrClause with_evars = onClause (discrSimpleClause with_evars) -let discrEverywhere with_evars = +let discrEverywhere with_evars = +(* tclORELSE - (Tacticals.tryAllClauses - (fun cl -> tclCOMPLETE (discrSimpleClause with_evars cl))) - (fun gls -> +*) + (if discr_do_intro () then + (tclTHEN + (tclREPEAT introf) + (Tacticals.tryAllHyps + (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) + else (* <= 8.2 compat *) + Tacticals.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 @@ -645,8 +756,8 @@ let discrHyp id gls = discrClause false (onHyp id) gls (* returns the sigma type (sigS, sigT) with the respective constructor depending on the sort *) -(* J.F.: correction du bug #1167 en accord avec Hugo. *) - +(* J.F.: correction du bug #1167 en accord avec Hugo. *) + let find_sigma_data s = build_sigma_type () (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser @@ -699,8 +810,8 @@ let minimal_free_rels_rec env sigma = in minimalrec_free_rels_rec Intset.empty (* [sig_clausal_form siglen ty] - - Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the + + Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the type of ty), and return: (1) a pattern, with meta-variables in it for various arguments, @@ -714,9 +825,9 @@ let minimal_free_rels_rec env sigma = (4) a typing for each patvar - WARNING: No checking is done to make sure that the + WARNING: No checking is done to make sure that the sigS(or sigT)'s are actually there. - - Only homogeneous pairs are built i.e. pairs where all the + - Only homogeneous pairs are built i.e. pairs where all the dependencies are of the same sort [sig_clausal_form] proceed as follows: the default tuple is @@ -735,7 +846,7 @@ let minimal_free_rels_rec env sigma = *) let sig_clausal_form env sigma sort_of_ty siglen ty dflt = - let { intro = exist_term } = find_sigma_data sort_of_ty in + let { intro = exist_term } = find_sigma_data 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 @@ -745,17 +856,17 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = (* the_conv_x had a side-effect on evdref *) dflt else - error "Cannot solve an unification problem." + error "Cannot solve a unification problem." else - let (a,p_i_minus_1) = match whd_beta_stack (evars_of !evdref) p_i with + 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 let rty = beta_applist(p_i_minus_1,[ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in match - Evd.existential_opt_value (Evd.evars_of !evdref) - (destEvar ev) + Evd.existential_opt_value !evdref + (destEvar ev) with | Some w -> let w_type = type_of env sigma w in @@ -766,7 +877,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = | None -> anomaly "Not enough components to build the dependent tuple" in let scf = sigrec_clausal_form siglen ty in - Evarutil.nf_evar (Evd.evars_of !evdref) scf + 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 @@ -831,7 +942,7 @@ let make_iterated_tuple env sigma dflt (z,zty) = 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 + List.fold_left (make_tuple env sigma) (z,zty) sorted_rels in assert (closed0 tuplety); let n = List.length sorted_rels in @@ -856,29 +967,29 @@ let build_injector sigma env dflt c cpath = (* let try_delta_expand env sigma t = - let whdt = whd_betadeltaiota env sigma t in + let whdt = whd_betadeltaiota env sigma t in let rec hd_rec c = match kind_of_term c with | Construct _ -> whdt | App (f,_) -> hd_rec f | Cast (c,_,_) -> hd_rec c | _ -> t - in - hd_rec whdt + in + hd_rec whdt *) -(* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it +(* 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 *) -let simplify_args env sigma t = +let simplify_args env sigma t = (* Quick hack to reduce in arguments of eq only *) match decompose_app t with - | eq, [t;c1;c2] -> applist (eq,[t;nf env sigma c1;nf env sigma c2]) - | eq, [t1;c1;t2;c2] -> applist (eq,[t1;nf env sigma c1;t2;nf env sigma c2]) + | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma c1;simpl env sigma c2]) + | 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 = +let inject_at_positions env sigma (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 = @@ -896,25 +1007,29 @@ let inject_at_positions env sigma (eq,(t,t1,t2)) eq_clause posns = posns in if injectors = [] then errorlabstrm "Equality.inj" (str "Failed to decompose the equality."); - tclMAP - (fun (pf,ty) -> tclTHENS (cut ty) [tclIDTAC; refine pf]) - injectors + 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)) eq_clause = - let sigma = Evd.evars_of eq_clause.evd in +let injEq ipats (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" + errorlabstrm "Equality.inj" (str"Nothing to do, it is an equality between convertible terms.") | Inr posns -> -(* Est-ce utile à partir du moment où les arguments projetés subissent "nf" ? +(* 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 *) @@ -922,7 +1037,7 @@ let injEq ipats (eq,(t,t1,t2)) eq_clause = (* 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 eqTypeDest = fst (destApp t) in let _,ar1 = destApp t1 and _,ar2 = destApp t2 in let ind = destInd ar1.(0) in @@ -933,27 +1048,26 @@ let injEq ipats (eq,(t,t1,t2)) eq_clause = (* 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_dec_proof ind=true) && + (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind=true) && (is_conv env sigma (ar1.(2)) (ar2.(2)) = true)) - then ( + then ( (* Require Import Eqdec_dec copied from vernac_require in vernacentries.ml*) - let qidl = qualid_of_reference + let qidl = qualid_of_reference (Ident (dummy_loc,id_of_string "Eqdep_dec")) in - Library.require_library [qidl] (Some false); + 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);Ind_tables.find_eq_dec_proof ind; + [|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) + ) else (raise Not_dep_pair) ) with _ -> - tclTHEN - (inject_at_positions env sigma (eq,(t,t1,t2)) eq_clause posns) - (intros_pattern no_move ipats) + 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) @@ -964,21 +1078,17 @@ let injClause ipats with_evars = function 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 = Evd.evars_of clause.evd in - let env = pf_env gls in +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 | Inr posns -> - tclTHEN - (inject_at_positions env sigma (lbeq,(t,t1,t2)) clause - (List.rev posns)) - (ntac (List.length posns)) - gls + inject_at_positions env sigma u clause (List.rev posns) ntac gls let dEqThen with_evars ntac = function | None -> onNegatedEquality with_evars (decompEqThen ntac) @@ -986,28 +1096,27 @@ let dEqThen with_evars ntac = function let dEq with_evars = dEqThen with_evars (fun x -> tclIDTAC) -let rewrite_msg = function - | None -> str "passed term is not a primitive equality" - | Some id -> pr_id id ++ str "does not satisfy preconditions " +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,(t,e1,e2)) = find_eq_data_decompose eqn in - applist(lbeq.eq,[t;e2;e1]) + let (lbeq,eq_args) = find_eq_data eqn in + applist(lbeq.eq,swap_equality_args eq_args) let swapEquandsInConcl gls = - let (lbeq,(t,e1,e2)) = find_eq_data_decompose (pf_concl gls) in + let (lbeq,eq_args) = find_eq_data (pf_concl gls) in let sym_equal = lbeq.sym in - refine (applist(sym_equal,[t;e2;e1;Evarutil.mk_new_meta()])) gls - -let swapEquandsInHyp id gls = - cut_replacing id (swap_equands gls (pf_get_hyp_typ gls id)) - (tclTHEN swapEquandsInConcl) gls + 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 false None gls in + let eq_elim = find_elim lbeq.eq (Some false) false None [e1;e2] gls in (* build substitution predicate *) let p = lambda_create (pf_env gls) (t,body) in (* apply substitution scheme *) @@ -1020,17 +1129,22 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls = (existT e1 (existT e2 ... (existT en en+1) ... )) + of type {x1:T1 & {x2:T2(x1) & ... {xn:Tn(x1..xn-1) & en+1 } } } + and B might contain instances of the ei, we will return the term: - ([x1:ty(e1)]...[xn:ty(en)]B - (projS1 (mkRel 1)) - (projS1 (projS2 (mkRel 1))) - ... etc ...) + ([x1:ty1]...[xn+1:tyn+1]B + (projT1 (mkRel 1)) + (projT1 (projT2 (mkRel 1))) + ... + (projT1 (projT2^n (mkRel 1))) + (projT2 (projT2^n (mkRel 1))) - That is, we will abstract out the terms e1...en+1 as usual, but + That is, we will abstract out the terms e1...en+1 of types + t1 (=_beta T1), ..., tn+1 (=_beta Tn+1(e1..en)) as usual, but will then produce a term in which the abstraction is on a single term - the debruijn index [mkRel 1], which will be of the same type - as dep_pair. + as dep_pair (note that the abstracted body may not be typable!). ALGORITHM for abstraction: @@ -1041,7 +1155,7 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls = *) -let decomp_tuple_term env c t = +let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = try let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in @@ -1054,23 +1168,32 @@ let decomp_tuple_term env c t = in List.split (decomprec (mkRel 1) c t) -let subst_tuple_term env sigma dep_pair b = - let typ = get_type_of env sigma dep_pair in - let e_list,proj_list = decomp_tuple_term env dep_pair typ in +let subst_tuple_term env sigma dep_pair1 dep_pair2 b = + let typ = get_type_of env sigma dep_pair1 in + (* We rewrite dep_pair1 ... *) + let e1_list,proj_list = decomp_tuple_term env dep_pair1 typ in let abst_B = List.fold_right - (fun (e,t) body -> lambda_create env (t,subst_term e body)) e_list b in - beta_applist(abst_B,proj_list) + (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in + (* ... and use dep_pair2 to compute the expected goal *) + let e2_list,_ = decomp_tuple_term env dep_pair2 typ in + let pred_body = beta_applist(abst_B,proj_list) in + let expected_goal = beta_applist (abst_B,List.map fst e2_list) in + (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) + let expected_goal = nf_betaiota sigma expected_goal in + pred_body,expected_goal -(* Comme "replace" mais decompose les egalites dependantes *) +(* Like "replace" but decompose dependent equalities *) exception NothingToRewrite let cutSubstInConcl_RL eqn gls = - let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose eqn in - let body = pf_apply subst_tuple_term gls e2 (pf_concl gls) in + 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; - bareRevSubstInConcl lbeq body eq gls + tclTHENFIRST + (bareRevSubstInConcl lbeq body eq) + (convert_concl expected_goal DEFAULTcast) gls (* |- (P e1) BY CutSubstInConcl_LR (eq T e1 e2) @@ -1085,11 +1208,14 @@ let cutSubstInConcl_LR eqn 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 eqn in - let body = pf_apply subst_tuple_term gls e1 (pf_get_hyp_typ gls id) in + 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 (subst1 e2 body) - (tclTHENFIRST (bareRevSubstInConcl lbeq body eq)) gls + 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) @@ -1099,12 +1225,12 @@ let cutSubstInHyp_RL eqn id gls = let cutSubstInHyp l2r = if l2r then cutSubstInHyp_LR else cutSubstInHyp_RL let try_rewrite tac gls = - try + try tac gls - with + with | PatternMatchingFailure -> errorlabstrm "try_rewrite" (str "Not a primitive equality here.") - | e when catchable_exception e -> + | e when catchable_exception e -> errorlabstrm "try_rewrite" (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") | NothingToRewrite -> @@ -1122,7 +1248,8 @@ let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls gls = let eq = pf_apply get_type_of gls c in - tclTHENS (cutSubstClause l2r eq cls) [tclIDTAC; exact_no_check c] gls + tclTHENS (cutSubstClause l2r eq cls) + [tclIDTAC; exact_no_check c] gls let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) let rewriteInHyp l2r c id = rewriteClause l2r c (Some id) @@ -1155,8 +1282,7 @@ let unfold_body x gl = | _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") in let aft = afterHyp x gl in - let hl = List.fold_right - (fun (y,yval,_) cl -> ((all_occurrences_expr,y),InHyp) :: cl) aft [] in + 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 @@ -1165,19 +1291,22 @@ let unfold_body x gl = +let restrict_to_eq_and_identity eq = (* compatibility *) + if eq <> constr_of_global glob_eq && eq <> constr_of_global glob_identity then + raise PatternMatchingFailure exception FoundHyp of (identifier * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *) -let is_eq_x x (id,_,c) = +let is_eq_x gl x (id,_,c) = try - let (_,lhs,rhs) = snd (find_eq_data_decompose c) in + let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in if (x = lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); if (x = rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) with PatternMatchingFailure -> () -let subst_one x gl = +let subst_one dep_proof_ok x gl = let hyps = pf_hyps gl in let (_,xval,_) = pf_get_hyp gl x in (* If x has a body, simply replace x with body and clear x *) @@ -1185,9 +1314,9 @@ let subst_one x gl = (* x is a variable: *) let varx = mkVar x in (* Find a non-recursive definition for x *) - let (hyp,rhs,dir) = + let (hyp,rhs,dir) = try - let test hyp _ = is_eq_x varx hyp in + 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 ++ @@ -1195,8 +1324,8 @@ let subst_one x gl = with FoundHyp res -> res in (* The set of hypotheses using x *) - let depdecls = - let test (id,_,c as dcl) = + let depdecls = + let test (id,_,c as dcl) = if id <> hyp && occur_var_in_decl (pf_env gl) x dcl then dcl else failwith "caught" in List.rev (map_succeed test hyps) in @@ -1219,10 +1348,10 @@ let subst_one x gl = (Some (replace_term varx rhs htyp)) nowhere in let need_rewrite = dephyps <> [] || depconcl in - tclTHENLIST + tclTHENLIST ((if need_rewrite then [generalize abshyps; - (if dir then rewriteLR else rewriteRL) (mkVar hyp); + general_rewrite dir all_occurrences dep_proof_ok (mkVar hyp); thin dephyps; tclMAP introtac depdecls] else @@ -1230,111 +1359,81 @@ let subst_one x gl = tclMAP introtac depdecls]) @ [tclTRY (clear [x;hyp])]) gl -let subst ids = tclTHEN tclNORMEVAR (tclMAP subst_one ids) +let subst_gen dep_proof_ok ids = + tclTHEN tclNORMEVAR (tclMAP (subst_one dep_proof_ok) ids) + +let subst = subst_gen true -let subst_all gl = +type subst_tactic_flags = { + only_leibniz : bool; + rewrite_dependent_proof : bool +} + +let default_subst_tactic_flags () = + if Flags.version_strictly_greater Flags.V8_2 then + { only_leibniz = false; rewrite_dependent_proof = true } + else + { only_leibniz = true; rewrite_dependent_proof = false } + +let subst_all ?(flags=default_subst_tactic_flags ()) gl = let test (_,c) = try - let (_,x,y) = snd (find_eq_data_decompose c) in + let lbeq,(_,x,y) = find_eq_data_decompose gl c in + if flags.only_leibniz then restrict_to_eq_and_identity lbeq.eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if eq_constr x y then failwith "caught"; - match kind_of_term x with Var x -> x | _ -> + match kind_of_term x with Var x -> x | _ -> match kind_of_term y with Var y -> y | _ -> failwith "caught" with PatternMatchingFailure -> failwith "caught" in let ids = map_succeed test (pf_hyps_types gl) in let ids = list_uniquize ids in - subst ids gl - + subst_gen flags.rewrite_dependent_proof ids gl -(* Rewrite the first assumption for which the condition faildir does not fail +(* Rewrite the first assumption for which the condition faildir does not fail and gives the direction of the rewrite *) let cond_eq_term_left c t gl = try - let (_,x,_) = snd (find_eq_data_decompose t) in + let (_,x,_) = snd (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" -let cond_eq_term_right c t gl = +let cond_eq_term_right c t gl = try - let (_,_,x) = snd (find_eq_data_decompose t) in + let (_,_,x) = snd (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" -let cond_eq_term c t gl = +let cond_eq_term c t gl = try - let (_,x,y) = snd (find_eq_data_decompose t) in - if pf_conv_x gl c x then true + let (_,x,y) = snd (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" -let rewrite_multi_assumption_cond cond_eq_term cl gl = - let rec arec = function +let rewrite_multi_assumption_cond cond_eq_term cl gl = + let rec arec = function | [] -> error "No such assumption." - | (id,_,t) ::rest -> - begin - try - let dir = cond_eq_term t gl in - general_multi_rewrite dir false (inj_open (mkVar id),NoBindings) cl gl + | (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 end - in + in arec (pf_hyps gl) -let replace_multi_term dir_opt c = - let cond_eq_fun = - match dir_opt with +let replace_multi_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 - -(* JF. old version -let rewrite_assumption_cond faildir gl = - let rec arec = function - | [] -> error "No such assumption." - | (id,_,t)::rest -> - (try let dir = faildir t gl in - general_rewrite dir (mkVar id) gl - with Failure _ | UserError _ -> arec rest) - in arec (pf_hyps gl) - - -let rewrite_assumption_cond_in faildir hyp gl = - let rec arec = function - | [] -> error "No such assumption." - | (id,_,t)::rest -> - (try let dir = faildir t gl in - general_rewrite_in dir hyp (mkVar id) gl - with Failure _ | UserError _ -> arec rest) - in arec (pf_hyps gl) - -let replace_term_left t = rewrite_assumption_cond (cond_eq_term_left t) - -let replace_term_right t = rewrite_assumption_cond (cond_eq_term_right t) - -let replace_term t = rewrite_assumption_cond (cond_eq_term t) - -let replace_term_in_left t = rewrite_assumption_cond_in (cond_eq_term_left t) - -let replace_term_in_right t = rewrite_assumption_cond_in (cond_eq_term_right t) - -let replace_term_in t = rewrite_assumption_cond_in (cond_eq_term t) -*) - -let replace_term_left t = replace_multi_term (Some true) t Tacticals.onConcl - -let replace_term_right t = replace_multi_term (Some false) t Tacticals.onConcl - -let replace_term t = replace_multi_term None t Tacticals.onConcl - -let replace_term_in_left t hyp = replace_multi_term (Some true) t (Tacticals.onHyp hyp) - -let replace_term_in_right t hyp = replace_multi_term (Some false) t (Tacticals.onHyp hyp) - -let replace_term_in t hyp = replace_multi_term None t (Tacticals.onHyp hyp) + in + rewrite_multi_assumption_cond cond_eq_fun -let _ = Tactics.register_general_multi_rewrite general_multi_rewrite +let _ = Tactics.register_general_multi_rewrite + (fun b evars t cls -> general_multi_rewrite b evars t cls) diff --git a/tactics/equality.mli b/tactics/equality.mli index 86ad3293..b5c14739 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: equality.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) +(*i $Id$ i*) (*i*) open Util @@ -25,43 +25,56 @@ open Tacexpr open Termops open Rawterm open Genarg +open Ind_tables (*i*) -val general_rewrite_bindings : - bool -> occurrences -> constr with_bindings -> evars_flag -> tactic -val general_rewrite : - bool -> occurrences -> constr -> tactic +type dep_proof_flag = bool (* true = support rewriting dependent proofs *) -(* Obsolete, use [general_rewrite_bindings l2r] -[val rewriteLR_bindings : constr with_bindings -> tactic] -[val rewriteRL_bindings : constr with_bindings -> tactic] -*) +type orientation = bool + +type conditions = + | Naive (* Only try the first occurence of the lemma (default) *) + | FirstSolved (* Use the first match whose side-conditions are solved *) + | AllMatches (* Rewrite all matches whose side-conditions are solved *) + +val general_rewrite_bindings : + orientation -> occurrences -> dep_proof_flag -> + ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic +val general_rewrite : + orientation -> occurrences -> dep_proof_flag -> + ?tac:(tactic * conditions) -> constr -> tactic (* Equivalent to [general_rewrite l2r] *) -val rewriteLR : constr -> tactic -val rewriteRL : constr -> tactic +val rewriteLR : ?tac:(tactic * conditions) -> constr -> tactic +val rewriteRL : ?tac:(tactic * conditions) -> constr -> tactic (* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *) -val register_general_setoid_rewrite_clause : - (identifier option -> bool -> - occurrences -> open_constr -> new_goals:constr list -> tactic) -> unit -val register_is_applied_setoid_relation : (constr -> bool) -> unit +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_rewrite_ebindings_clause : identifier option -> + orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) -> + constr with_bindings -> evars_flag -> tactic val general_rewrite_bindings_in : - bool -> occurrences -> identifier -> constr with_bindings -> evars_flag -> tactic + orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) -> + identifier -> constr with_bindings -> evars_flag -> tactic val general_rewrite_in : - bool -> occurrences -> identifier -> constr -> evars_flag -> tactic + orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) -> + identifier -> constr -> evars_flag -> tactic + +val general_multi_rewrite : + orientation -> evars_flag -> ?tac:(tactic * conditions) -> constr with_bindings -> clause -> tactic -val general_multi_rewrite : - bool -> evars_flag -> open_constr with_bindings -> clause -> tactic -val general_multi_multi_rewrite : - evars_flag -> (bool * multi * open_constr with_bindings) list -> clause -> - tactic option -> tactic +type delayed_open_constr_with_bindings = + env -> evar_map -> evar_map * constr with_bindings -val conditional_rewrite : bool -> tactic -> open_constr with_bindings -> tactic -val conditional_rewrite_in : - bool -> identifier -> tactic -> open_constr with_bindings -> tactic +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 @@ -69,24 +82,24 @@ 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_ebindings -> 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 -val discr_tac : evars_flag -> - constr with_ebindings induction_arg option -> tactic +val discr_tac : evars_flag -> + constr with_bindings induction_arg option -> tactic val inj : intro_pattern_expr located list -> evars_flag -> - constr with_ebindings -> tactic -val injClause : intro_pattern_expr located list -> evars_flag -> - constr with_ebindings induction_arg option -> tactic + 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 -val dEq : evars_flag -> constr with_ebindings induction_arg option -> tactic -val dEqThen : evars_flag -> (int -> tactic) -> constr with_ebindings induction_arg option -> 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 make_iterated_tuple : +val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> constr * constr * constr (* The family cutRewriteIn expect an equality statement *) @@ -100,26 +113,6 @@ val rewriteInConcl : bool -> constr -> tactic (* Expect the proof of an equality; fails with raw internal errors *) val substClause : bool -> constr -> identifier option -> tactic -(* -(* [substHypInConcl l2r id] is obsolete: use [rewriteInConcl l2r (mkVar id)] *) -val substHypInConcl : bool -> identifier -> tactic - -(* [substConcl] is an obsolete synonym for [cutRewriteInConcl] *) -val substConcl : bool -> constr -> tactic - -(* [substHyp] is an obsolete synonym of [cutRewriteInHyp] *) -val substHyp : bool -> types -> identifier -> tactic -*) - -(* Obsolete, use [rewriteInConcl lr (mkVar id)] in concl - or [rewriteInHyp lr (mkVar id) (Some hyp)] in hyp - (which, if they fail, raise only UserError, not PatternMatchingFailure) - or [substClause lr (mkVar id) None] - or [substClause lr (mkVar id) (Some hyp)] -[val hypSubst_LR : identifier -> clause -> tactic] -[val hypSubst_RL : identifier -> clause -> tactic] -*) - val discriminable : env -> evar_map -> constr -> constr -> bool val injectable : env -> evar_map -> constr -> constr -> bool @@ -127,12 +120,19 @@ val injectable : env -> evar_map -> constr -> constr -> bool val unfold_body : identifier -> 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 : tactic +val subst_all : ?flags:subst_tactic_flags -> tactic (* Replace term *) -(* [replace_multi_term dir_opt c cl] +(* [replace_multi_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 set_eq_dec_scheme_kind : mutual scheme_kind -> unit diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 67b89888..c8550ff5 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: evar_tactics.ml 12102 2009-04-24 10:48:11Z herbelin $ *) +(* $Id$ *) open Term open Util @@ -21,61 +21,39 @@ open Termops (* The instantiate tactic *) -let evar_list evc c = - let rec evrec acc c = - match kind_of_term c with - | Evar (n, _) when Evd.mem evc n -> c :: acc - | _ -> fold_constr evrec acc c - in - evrec [] c - -let instantiate n (ist,rawc) ido gl = +let instantiate n (ist,rawc) ido gl = let sigma = gl.sigma in - let evl = + let evl = match ido with - ConclLocation () -> evar_list sigma gl.it.evar_concl + ConclLocation () -> evar_list sigma gl.it.evar_concl | HypLocation (id,hloc) -> let decl = Environ.lookup_named_val id gl.it.evar_hyps in match hloc with - InHyp -> - (match decl with + InHyp -> + (match decl with (_,None,typ) -> evar_list sigma typ - | _ -> error + | _ -> error "Please be more specific: in type or value?") | InHypTypeOnly -> let (_, _, typ) = decl in evar_list sigma typ | InHypValueOnly -> - (match decl with + (match decl with (_,Some body,_) -> evar_list sigma body | _ -> error "Not a defined hypothesis.") in if List.length evl < n then - error "not enough uninstantiated existential variables"; + error "Not enough uninstantiated existential variables."; if n <= 0 then error "Incorrect existential variable index."; - let ev,_ = destEvar (List.nth evl (n-1)) in - let env = Evd.evar_env (Evd.find sigma ev) in - let ltac_vars = Tacinterp.extract_ltac_vars ist sigma env in - let evd' = w_refine ev (ltac_vars,rawc) (create_goal_evar_defs sigma) in + 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 (evars_of evd')) + (tclEVARS sigma') tclNORMEVAR gl - -(* -let pfic gls c = - let evc = gls.sigma in - Constrintern.interp_constr evc (Global.env_of_context gls.it.evar_hyps) c - -let instantiate_tac = function - | [Integer n; Command com] -> - (fun gl -> instantiate n (pfic gl com) gl) - | [Integer n; Constr c] -> - (fun gl -> instantiate n c gl) - | _ -> invalid_arg "Instantiate called with bad arguments" -*) let let_evar name typ gls = - let evd = Evd.create_goal_evar_defs gls.sigma in - let evd',evar = Evarutil.new_evar evd (pf_env gls) typ in - Refiner.tclTHEN (Refiner.tclEVARS (evars_of evd')) + let sigma',evar = Evarutil.new_evar gls.sigma (pf_env gls) typ in + Refiner.tclTHEN (Refiner.tclEVARS sigma') (Tactics.letin_tac None name evar None nowhere) gls - + diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli index f577b338..2e30cdfb 100644 --- a/tactics/evar_tactics.mli +++ b/tactics/evar_tactics.mli @@ -6,14 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: evar_tactics.mli 12102 2009-04-24 10:48:11Z herbelin $ i*) +(*i $Id$ i*) open Tacmach open Names open Tacexpr open Termops -val instantiate : int -> Tacinterp.interp_sign * Rawterm.rawconstr -> +val instantiate : int -> Tacinterp.interp_sign * Rawterm.rawconstr -> (identifier * hyp_location_flag, unit) location -> tactic (*i diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 5eb333a0..adf8275e 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: extraargs.ml4 12102 2009-04-24 10:48:11Z herbelin $ *) +(* $Id$ *) open Pp open Pcoq @@ -41,9 +41,9 @@ let pr_int_list _prc _prlc _prt l = in aux l ARGUMENT EXTEND int_nelist - TYPED AS int list + TYPED AS int list PRINTED BY pr_int_list - RAW_TYPED AS int list + RAW_TYPED AS int list RAW_PRINTED BY pr_int_list GLOB_TYPED AS int list GLOB_PRINTED BY pr_int_list @@ -65,11 +65,11 @@ let coerce_to_int = function let int_list_of_VList = function | VList l -> List.map (fun n -> coerce_to_int n) l | _ -> raise Not_found - -let interp_occs ist gl l = + +let interp_occs ist gl l = match l with | ArgArg x -> x - | ArgVar (_,id as locid) -> + | ArgVar (_,id as locid) -> (try int_list_of_VList (List.assoc id ist.lfun) with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) @@ -111,14 +111,14 @@ let subst_raw = Tacinterp.subst_rawconstr_and_expr ARGUMENT EXTEND raw TYPED AS rawconstr PRINTED BY pr_rawc - - INTERPRETED BY interp_raw + + INTERPRETED BY interp_raw GLOBALIZED BY glob_raw SUBSTITUTED BY subst_raw - + RAW_TYPED AS constr_expr RAW_PRINTED BY pr_gen - + GLOB_TYPED AS rawconstr_and_expr GLOB_PRINTED BY pr_gen [ lconstr(c) ] -> [ c ] @@ -132,9 +132,9 @@ type place = identifier gen_place let pr_gen_place pr_id = function ConclLocation () -> Pp.mt () | HypLocation (id,InHyp) -> str "in " ++ pr_id id - | HypLocation (id,InHypTypeOnly) -> + | HypLocation (id,InHypTypeOnly) -> str "in (Type of " ++ pr_id id ++ str ")" - | HypLocation (id,InHypValueOnly) -> + | HypLocation (id,InHypValueOnly) -> str "in (Value of " ++ pr_id id ++ str ")" let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id) @@ -148,7 +148,7 @@ let interp_place ist gl = function ConclLocation () -> ConclLocation () | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl) -let subst_place subst pl = pl +let subst_place subst pl = pl ARGUMENT EXTEND hloc TYPED AS place @@ -160,17 +160,17 @@ ARGUMENT EXTEND hloc RAW_PRINTED BY pr_loc_place GLOB_TYPED AS loc_place GLOB_PRINTED BY pr_loc_place - [ ] -> + [ ] -> [ ConclLocation () ] - | [ "in" "|-" "*" ] -> + | [ "in" "|-" "*" ] -> [ ConclLocation () ] | [ "in" ident(id) ] -> [ HypLocation ((Util.dummy_loc,id),InHyp) ] -| [ "in" "(" "Type" "of" ident(id) ")" ] -> +| [ "in" "(" "Type" "of" ident(id) ")" ] -> [ HypLocation ((Util.dummy_loc,id),InHypTypeOnly) ] -| [ "in" "(" "Value" "of" ident(id) ")" ] -> +| [ "in" "(" "Value" "of" ident(id) ")" ] -> [ HypLocation ((Util.dummy_loc,id),InHypValueOnly) ] - + END @@ -181,10 +181,10 @@ ARGUMENT EXTEND hloc (* Julien: Mise en commun des differentes version de replace with in by *) -let pr_by_arg_tac _prc _prlc prtac opt_c = - match opt_c with +let pr_by_arg_tac _prc _prlc prtac opt_c = + match opt_c with | None -> mt () - | Some t -> spc () ++ hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) + | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) ARGUMENT EXTEND by_arg_tac TYPED AS tactic_opt @@ -192,37 +192,37 @@ ARGUMENT EXTEND by_arg_tac | [ "by" tactic3(c) ] -> [ Some c ] | [ ] -> [ None ] END - -let pr_in_hyp pr_id (lo,concl) : Pp.std_ppcmds = - match lo,concl with + +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 spc pr_id l ++ - match concl with + | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-" + | Some l,_ -> + str "in" ++ + Util.prlist (fun id -> spc () ++ pr_id 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_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_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_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 - TYPED AS var list +ARGUMENT EXTEND comma_var_lne + TYPED AS var list PRINTED BY pr_var_list_typed - RAW_TYPED AS var list + RAW_TYPED AS var list RAW_PRINTED BY pr_var_list GLOB_TYPED AS var list GLOB_PRINTED BY pr_var_list @@ -230,10 +230,10 @@ ARGUMENT EXTEND comma_var_lne | [ var(x) "," comma_var_lne(l) ] -> [x::l] END -ARGUMENT EXTEND comma_var_l - TYPED AS var list +ARGUMENT EXTEND comma_var_l + TYPED AS var list PRINTED BY pr_var_list_typed - RAW_TYPED AS var list + RAW_TYPED AS var list RAW_PRINTED BY pr_var_list GLOB_TYPED AS var list GLOB_PRINTED BY pr_var_list @@ -241,10 +241,10 @@ ARGUMENT EXTEND comma_var_l | [] -> [ [] ] END -let pr_in_concl _ _ _ = function true -> str "|- " ++ spc () ++ str "*" | _ -> str "|-" +let pr_in_concl _ _ _ = function true -> str "|- " ++ spc () ++ str "*" | _ -> str "|-" -ARGUMENT EXTEND inconcl - TYPED AS bool +ARGUMENT EXTEND inconcl + TYPED AS bool PRINTED BY pr_in_concl | [ "|-" "*" ] -> [ true ] | [ "|-" ] -> [ false ] @@ -255,24 +255,24 @@ END ARGUMENT EXTEND in_arg_hyp TYPED AS var list option * bool PRINTED BY pr_in_arg_hyp_typed - RAW_TYPED AS var list option * bool + RAW_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 +| [ "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 gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = +let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = {Tacexpr.onhyps= - Option.map - (fun l -> - List.map + Option.map + (fun l -> + List.map (fun id -> ( (all_occurrences_expr,trad_id id),InHyp)) l ) @@ -280,8 +280,8 @@ let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = 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) +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 *) @@ -297,7 +297,7 @@ let (wit_r_field, globwit_r_field, rawwit_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" @@ -327,7 +327,7 @@ let pr_r_int31_field _ _ _ i31f = | Retroknowledge.Int31PhiInv -> str "phi inv" | Retroknowledge.Int31Plus -> str "plus" | Retroknowledge.Int31Times -> str "times" - | _ -> assert false + | _ -> assert false let pr_retroknowledge_field _ _ _ f = match f with @@ -335,7 +335,7 @@ let pr_retroknowledge_field _ _ _ f = | 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) ++ - str "in " ++ str group + str "in " ++ str group ARGUMENT EXTEND retroknowledge_nat TYPED AS r_nat_field @@ -347,7 +347,7 @@ END ARGUMENT EXTEND retroknowledge_binary_n -TYPED AS r_n_field +TYPED AS r_n_field PRINTED BY pr_r_n_field | [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] | [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] @@ -360,7 +360,7 @@ PRINTED BY pr_r_n_field END ARGUMENT EXTEND retroknowledge_int31 -TYPED AS r_int31_field +TYPED AS r_int31_field PRINTED BY pr_r_int31_field | [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] | [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] @@ -385,8 +385,8 @@ PRINTED BY pr_r_int31_field END -ARGUMENT EXTEND retroknowledge_field -TYPED AS r_field +ARGUMENT EXTEND retroknowledge_field +TYPED AS r_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 b64adf24..4492fd84 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraargs.mli 12102 2009-04-24 10:48:11Z herbelin $ i*) +(*i $Id$ i*) open Tacexpr open Term diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index ee01f839..0bb6ce96 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: extratactics.ml4 11800 2009-01-18 18:34:15Z msozeau $ *) +(* $Id$ *) open Pp open Pcoq @@ -19,29 +19,45 @@ open Names open Tacexpr open Rawterm open Tactics - -(* Equality *) +open Util +open Termops +open Evd open Equality +(**********************************************************************) +(* replace, discriminate, injection, simplify_eq *) +(* cutrewrite, dependent rewrite *) + +let replace_in_clause_maybe_by (sigma1,c1) c2 in_hyp tac = + Refiner.tclWITHHOLES false + (replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp)) + 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) -TACTIC EXTEND replace - ["replace" 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) (Option.map Tacinterp.eval_tactic tac) ] +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 in_hyp tac ] END TACTIC EXTEND replace_term_left - [ "replace" "->" constr(c) in_arg_hyp(in_hyp) ] - -> [ replace_multi_term (Some true) c (glob_in_arg_hyp_to_clause in_hyp)] + [ "replace" "->" open_constr(c) in_arg_hyp(in_hyp) ] + -> [ replace_multi_term (Some true) c in_hyp] END TACTIC EXTEND replace_term_right - [ "replace" "<-" constr(c) in_arg_hyp(in_hyp) ] - -> [replace_multi_term (Some false) c (glob_in_arg_hyp_to_clause in_hyp)] + [ "replace" "<-" open_constr(c) in_arg_hyp(in_hyp) ] + -> [replace_multi_term (Some false) c in_hyp] END TACTIC EXTEND replace_term - [ "replace" constr(c) in_arg_hyp(in_hyp) ] - -> [ replace_multi_term None c (glob_in_arg_hyp_to_clause in_hyp) ] + [ "replace" open_constr(c) in_arg_hyp(in_hyp) ] + -> [ replace_multi_term None c in_hyp ] END let induction_arg_of_quantified_hyp = function @@ -52,9 +68,13 @@ let induction_arg_of_quantified_hyp = function 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)) + TACTIC EXTEND simplify_eq_main | [ "simplify_eq" constr_with_bindings(c) ] -> - [ dEq false (Some (ElimOnConstr c)) ] + [ elimOnConstrWithHoles dEq false c ] END TACTIC EXTEND simplify_eq [ "simplify_eq" ] -> [ dEq false None ] @@ -63,7 +83,7 @@ TACTIC EXTEND simplify_eq END TACTIC EXTEND esimplify_eq_main | [ "esimplify_eq" constr_with_bindings(c) ] -> - [ dEq true (Some (ElimOnConstr c)) ] + [ elimOnConstrWithHoles dEq true c ] END TACTIC EXTEND esimplify_eq | [ "esimplify_eq" ] -> [ dEq true None ] @@ -73,7 +93,7 @@ END TACTIC EXTEND discriminate_main | [ "discriminate" constr_with_bindings(c) ] -> - [ discr_tac false (Some (ElimOnConstr c)) ] + [ elimOnConstrWithHoles discr_tac false c ] END TACTIC EXTEND discriminate | [ "discriminate" ] -> [ discr_tac false None ] @@ -82,7 +102,7 @@ TACTIC EXTEND discriminate END TACTIC EXTEND ediscriminate_main | [ "ediscriminate" constr_with_bindings(c) ] -> - [ discr_tac true (Some (ElimOnConstr c)) ] + [ elimOnConstrWithHoles discr_tac true c ] END TACTIC EXTEND ediscriminate | [ "ediscriminate" ] -> [ discr_tac true None ] @@ -90,39 +110,40 @@ TACTIC EXTEND ediscriminate [ discr_tac true (Some (induction_arg_of_quantified_hyp h)) ] END -let h_discrHyp id = h_discriminate_main (Term.mkVar id,NoBindings) +let h_discrHyp id gl = + h_discriminate_main {it = Term.mkVar id,NoBindings; sigma = Refiner.project gl} gl TACTIC EXTEND injection_main | [ "injection" constr_with_bindings(c) ] -> - [ injClause [] false (Some (ElimOnConstr c)) ] -END + [ elimOnConstrWithHoles (injClause []) false c ] +END TACTIC EXTEND injection | [ "injection" ] -> [ injClause [] false None ] -| [ "injection" quantified_hypothesis(h) ] -> +| [ "injection" quantified_hypothesis(h) ] -> [ injClause [] false (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND einjection_main | [ "einjection" constr_with_bindings(c) ] -> - [ injClause [] true (Some (ElimOnConstr c)) ] + [ elimOnConstrWithHoles (injClause []) true c ] END TACTIC EXTEND einjection | [ "einjection" ] -> [ injClause [] true None ] | [ "einjection" quantified_hypothesis(h) ] -> [ injClause [] true (Some (induction_arg_of_quantified_hyp h)) ] -END +END TACTIC EXTEND injection_as_main | [ "injection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> - [ injClause ipat false (Some (ElimOnConstr c)) ] -END + [ elimOnConstrWithHoles (injClause ipat) false c ] +END TACTIC EXTEND injection_as | [ "injection" "as" simple_intropattern_list(ipat)] -> [ injClause ipat false None ] | [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] -> [ injClause ipat false (Some (induction_arg_of_quantified_hyp h)) ] -END +END TACTIC EXTEND einjection_as_main | [ "einjection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> - [ injClause ipat true (Some (ElimOnConstr c)) ] -END + [ elimOnConstrWithHoles (injClause ipat) true c ] +END TACTIC EXTEND einjection_as | [ "einjection" "as" simple_intropattern_list(ipat)] -> [ injClause ipat true None ] @@ -130,15 +151,8 @@ TACTIC EXTEND einjection_as [ injClause ipat true (Some (induction_arg_of_quantified_hyp h)) ] END -let h_injHyp id = h_injection_main (Term.mkVar id,NoBindings) - -TACTIC EXTEND conditional_rewrite -| [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) ] - -> [ conditional_rewrite b (snd tac) (inj_open (fst c), snd c) ] -| [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) - "in" hyp(h) ] - -> [ conditional_rewrite_in b h (snd tac) (inj_open (fst c), snd c) ] -END +let h_injHyp id gl = + h_injection_main { it = Term.mkVar id,NoBindings; sigma = Refiner.project gl } gl TACTIC EXTEND dependent_rewrite | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] @@ -152,50 +166,82 @@ TACTIC EXTEND cut_rewrite -> [ cutRewriteInHyp b eqn id ] END -(* Contradiction *) +(**********************************************************************) +(* Contradiction *) + open Contradiction TACTIC EXTEND absurd [ "absurd" constr(c) ] -> [ absurd c ] END +let onSomeWithHoles tac = function + | None -> tac None + | Some c -> Refiner.tclWITHHOLES false tac c.sigma (Some c.it) + TACTIC EXTEND contradiction - [ "contradiction" constr_with_bindings_opt(c) ] -> [ contradiction c ] + [ "contradiction" constr_with_bindings_opt(c) ] -> + [ onSomeWithHoles contradiction c ] END -(* AutoRewrite *) +(**********************************************************************) +(* AutoRewrite *) open Autorewrite -(* J.F : old version -TACTIC EXTEND autorewrite - [ "autorewrite" "with" ne_preident_list(l) ] -> - [ autorewrite Refiner.tclIDTAC l ] -| [ "autorewrite" "with" ne_preident_list(l) "using" tactic(t) ] -> - [ autorewrite (snd t) l ] -| [ "autorewrite" "with" ne_preident_list(l) "in" hyp(id) ] -> - [ autorewrite_in id Refiner.tclIDTAC l ] -| [ "autorewrite" "with" ne_preident_list(l) "in" hyp(id) "using" tactic(t) ] -> - [ autorewrite_in id (snd t) l ] -END -*) TACTIC EXTEND autorewrite | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) ] -> [ auto_multi_rewrite l (glob_in_arg_hyp_to_clause cl) ] | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] -> - [ - let cl = glob_in_arg_hyp_to_clause cl in + [ + let cl = glob_in_arg_hyp_to_clause cl in auto_multi_rewrite_with (snd 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 (snd t) l cl ] +END + +(**********************************************************************) +(* Rewrite star *) + +let rewrite_star clause orient occs (sigma,c) (tac : glob_tactic_expr option) = + let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in + Refiner. tclWITHHOLES false + (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true (c,NoBindings)) sigma true + +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) + +TACTIC EXTEND rewrite_star +| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star (Some id) o all_occurrences c tac ] +| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star None o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) open_constr(c) by_arg_tac(tac) ] -> + [ rewrite_star None o all_occurrences c tac ] + END - +(**********************************************************************) +(* Hint Rewrite *) let add_rewrite_hint name ort t lcsr = let env = Global.env() and sigma = Evd.empty in - let f c = Constrintern.interp_constr sigma env c, ort, t 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 @@ -204,10 +250,56 @@ VERNAC COMMAND EXTEND HintRewrite | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident(b) ] -> [ add_rewrite_hint b o t l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> + [ add_rewrite_hint "core" o (Tacexpr.TacId []) l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> + [ add_rewrite_hint "core" o t l ] END +(**********************************************************************) +(* Hint Resolve *) -(* Refine *) +open Term +open Coqlib + +let project_hint pri l2r c = + 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 t = + Tacred.reduce_to_quantified_ref env Evd.empty (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) + | _ -> assert false in + let p = + if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in + let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in + let c = it_mkLambda_or_LetIn + (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in + (pri,true,c) + +let add_hints_iff l2r lc n bl = + Auto.add_hints true bl + (Auto.HintsResolveEntry (List.map (project_hint n l2r) lc)) + +VERNAC COMMAND EXTEND HintResolveIffLR + [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n) + ":" preident_list(bl) ] -> + [ add_hints_iff true lc n bl ] +| [ "Hint" "Resolve" "->" ne_constr_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) + ":" preident_list(bl) ] -> + [ add_hints_iff false lc n bl ] +| [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n) ] -> + [ add_hints_iff false lc n ["core"] ] +END + +(**********************************************************************) +(* Refine *) open Refine @@ -217,7 +309,8 @@ END let refine_tac = h_refine -(* Inversion lemmas (Leminv) *) +(**********************************************************************) +(* Inversion lemmas (Leminv) *) open Inv open Leminv @@ -263,16 +356,25 @@ VERNAC COMMAND EXTEND DeriveDependentInversionClear -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] END -(* Subst *) +(**********************************************************************) +(* Subst *) TACTIC EXTEND subst | [ "subst" ne_var_list(l) ] -> [ subst l ] -| [ "subst" ] -> [ subst_all ] +| [ "subst" ] -> [ fun gl -> subst_all gl ] +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 ] END open Evar_tactics -(* evar creation *) +(**********************************************************************) +(* Evar creation *) TACTIC EXTEND evar [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ] @@ -289,7 +391,8 @@ TACTIC EXTEND instantiate END -(** Nijmegen "step" tactic for setoid rewriting *) +(**********************************************************************) +(** Nijmegen "step" tactic for setoid rewriting *) open Tactics open Tactics @@ -323,40 +426,37 @@ let step left x tac = (* Main function to push lemmas in persistent environment *) let cache_transitivity_lemma (_,(left,lem)) = - if left then + if left then transitivity_left_table := lem :: !transitivity_left_table else transitivity_right_table := lem :: !transitivity_right_table - -let subst_transitivity_lemma (_,subst,(b,ref)) = (b,subst_mps subst ref) + +let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) let (inTransitivity,_) = 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); subst_function = subst_transitivity_lemma; - classify_function = (fun (_,o) -> Substitute o); - export_function = (fun x -> Some x) } + classify_function = (fun o -> Substitute o) } (* Synchronisation with reset *) let freeze () = !transitivity_left_table, !transitivity_right_table -let unfreeze (l,r) = +let unfreeze (l,r) = transitivity_left_table := l; transitivity_right_table := r -let init () = +let init () = transitivity_left_table := []; transitivity_right_table := [] -let _ = +let _ = declare_summary "transitivity-steps" { freeze_function = freeze; unfreeze_function = unfreeze; - init_function = init; - survive_module = false; - survive_section = false } + init_function = init } (* Main entry points *) @@ -394,10 +494,11 @@ END -(*spiwack : Vernac commands for retroknowledge *) +(**********************************************************************) +(*spiwack : Vernac commands for retroknowledge *) VERNAC COMMAND EXTEND RetroknowledgeRegister - | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> + | [ "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 Global.register f tc tb ] @@ -405,19 +506,121 @@ END -(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as +(**********************************************************************) +(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) TACTIC EXTEND generalize_eqs -| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize id ~generalize_vars:false ] +| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] END -TACTIC EXTEND generalize_eqs_vars -| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize id ~generalize_vars:true ] +TACTIC EXTEND dep_generalize_eqs +| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] END +TACTIC EXTEND generalize_eqs_vars +| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] +END +TACTIC EXTEND dep_generalize_eqs_vars +| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] +END + +(** Tactic to automatically simplify hypotheses of the form [ΠΔ, x_i = t_i -> T] + where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated + during dependent induction. For internal use. *) + +TACTIC EXTEND specialize_eqs +[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ] +END + +(**********************************************************************) +(* A tactic that considers a given occurrence of [c] in [t] and *) +(* abstract the minimal set of all the occurrences of [c] so that the *) +(* abstraction [fun x -> t[x/c]] is well-typed *) +(* *) +(* Contributed by Chung-Kil Hur (Winter 2009) *) +(**********************************************************************) + +let subst_var_with_hole occ tid t = + let occref = if occ > 0 then ref occ else error_invalid_occurrence [occ] in + let locref = ref 0 in + let rec substrec = function + | RVar (_,id) as x -> + if id = tid + then (decr occref; if !occref = 0 then x + else (incr locref; RHole (Ploc.make !locref 0 (0,0),Evd.QuestionMark(Evd.Define true)))) + else x + | c -> map_rawconstr_left_to_right substrec c in + let t' = substrec t + in + if !occref > 0 then error_invalid_occurrence [occ] else t' + +let subst_hole_with_term occ tc t = + let locref = ref 0 in + let occref = ref occ in + let rec substrec = function + | RHole (_,Evd.QuestionMark(Evd.Define true)) -> + decr occref; if !occref = 0 then tc + else (incr locref; RHole (Ploc.make !locref 0 (0,0),Evd.QuestionMark(Evd.Define true))) + | c -> map_rawconstr_left_to_right substrec c + in + substrec t + +open Tacmach + +let out_arg = function + | ArgVar _ -> anomaly "Unevaluated or_var variable" + | ArgArg x -> x + +let hResolve id c occ t gl = + let sigma = project gl in + let env = clear_named_body id (pf_env gl) in + let env_ids = ids_of_context env in + let env_names = names_of_rel_context env in + let c_raw = Detyping.detype true env_ids env_names c in + let t_raw = Detyping.detype true env_ids env_names t in + let rec resolve_hole t_hole = + try + Pretyping.Default.understand sigma env t_hole + with + | Ploc.Exc (loc,Pretype_errors.PretypeError (_, Pretype_errors.UnsolvableImplicit _)) -> + resolve_hole (subst_hole_with_term (Ploc.line_nb loc) c_raw t_hole) + in + let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) 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 + +let hResolve_auto id c t gl = + let rec resolve_auto n = + try + hResolve id c n t gl + with + | UserError _ as e -> raise e + | _ -> resolve_auto (n+1) + in + resolve_auto 1 -TACTIC EXTEND dependent_pattern -| ["dependent_pattern" constr(c) ] -> [ dependent_pattern c ] +TACTIC EXTEND hresolve_core +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c (out_arg occ) t ] +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] END -TACTIC EXTEND resolve_classes -| ["resolve_classes" ] -> [ resolve_classes ] +(** + 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 + 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 + +TACTIC EXTEND hget_evar +| [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ] END + +(**********************************************************************) diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli index d43e4581..82006f60 100644 --- a/tactics/extratactics.mli +++ b/tactics/extratactics.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extratactics.mli 11166 2008-06-22 13:23:35Z herbelin $ i*) +(*i $Id$ i*) open Proof_type @@ -15,3 +15,4 @@ val h_injHyp : Names.identifier -> tactic val refine_tac : Evd.open_constr -> tactic +val onSomeWithHoles : ('a option -> tactic) -> 'a Evd.sigma option -> tactic diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml index 4ab40acb..5cc729f1 100644 --- a/tactics/hiddentac.ml +++ b/tactics/hiddentac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: hiddentac.ml 13124 2010-06-13 11:09:38Z herbelin $ *) +(* $Id$ *) open Term open Proof_type @@ -19,79 +19,69 @@ open Tacexpr open Tactics open Util -let inj_id id = (dummy_loc,id) -let inj_open c = (Evd.empty,c) -let inj_open_wb (c,b) = ((Evd.empty,c),b) -let inj_ia = function - | ElimOnConstr c -> ElimOnConstr (inj_open_wb c) - | ElimOnIdent id -> ElimOnIdent id - | ElimOnAnonHyp n -> ElimOnAnonHyp n -let inj_occ (occ,c) = (occ,inj_open c) - (* Basic tactics *) let h_intro_move x y = abstract_tactic (TacIntroMove (x, y)) (intro_move x y) let h_intro x = h_intro_move (Some x) no_move let h_intros_until x = abstract_tactic (TacIntrosUntil x) (intros_until x) let h_assumption = abstract_tactic TacAssumption assumption -let h_exact c = abstract_tactic (TacExact (inj_open c)) (exact_check c) +let h_exact c = abstract_tactic (TacExact c) (exact_check c) let h_exact_no_check c = - abstract_tactic (TacExactNoCheck (inj_open c)) (exact_no_check c) -let h_vm_cast_no_check c = - abstract_tactic (TacVmCastNoCheck (inj_open c)) (vm_cast_no_check c) + abstract_tactic (TacExactNoCheck c) (exact_no_check c) +let h_vm_cast_no_check c = + abstract_tactic (TacVmCastNoCheck c) (vm_cast_no_check c) let h_apply simple ev cb = - abstract_tactic (TacApply (simple,ev,cb,None)) - (apply_with_ebindings_gen simple ev cb) + abstract_tactic (TacApply (simple,ev,List.map snd cb,None)) + (apply_with_bindings_gen simple ev cb) let h_apply_in simple ev cb (id,ipat as inhyp) = - abstract_tactic (TacApply (simple,ev,cb,Some inhyp)) + abstract_tactic (TacApply (simple,ev,List.map snd cb,Some inhyp)) (apply_in simple ev id cb ipat) let h_elim ev cb cbo = - abstract_tactic (TacElim (ev,inj_open_wb cb,Option.map inj_open_wb cbo)) + abstract_tactic (TacElim (ev,cb,cbo)) (elim ev cb cbo) -let h_elim_type c = abstract_tactic (TacElimType (inj_open c)) (elim_type c) -let h_case ev cb = abstract_tactic (TacCase (ev,inj_open_wb cb)) (general_case_analysis ev cb) -let h_case_type c = abstract_tactic (TacCaseType (inj_open c)) (case_type c) +let h_elim_type c = abstract_tactic (TacElimType c) (elim_type c) +let h_case ev cb = abstract_tactic (TacCase (ev,cb)) (general_case_analysis ev cb) +let h_case_type c = abstract_tactic (TacCaseType c) (case_type c) let h_fix ido n = abstract_tactic (TacFix (ido,n)) (fix ido n) let h_mutual_fix b id n l = abstract_tactic - (TacMutualFix (b,id,n,List.map (fun (id,n,c) -> (id,n,inj_open c)) l)) - (mutual_fix id n l) + (TacMutualFix (b,id,n,l)) + (mutual_fix id n l 0) let h_cofix ido = abstract_tactic (TacCofix ido) (cofix ido) let h_mutual_cofix b id l = abstract_tactic - (TacMutualCofix (b,id,List.map (fun (id,c) -> (id,inj_open c)) l)) - (mutual_cofix id l) + (TacMutualCofix (b,id,l)) + (mutual_cofix id l 0) -let h_cut c = abstract_tactic (TacCut (inj_open c)) (cut c) +let h_cut c = abstract_tactic (TacCut c) (cut c) let h_generalize_gen cl = - abstract_tactic (TacGeneralize (List.map (on_fst inj_occ) cl)) + abstract_tactic (TacGeneralize cl) (generalize_gen (List.map (on_fst Redexpr.out_with_occurrences) cl)) let h_generalize cl = h_generalize_gen (List.map (fun c -> ((all_occurrences_expr,c),Names.Anonymous)) cl) let h_generalize_dep c = - abstract_tactic (TacGeneralizeDep (inj_open c))(generalize_dep c) + abstract_tactic (TacGeneralizeDep c) (generalize_dep c) let h_let_tac b na c cl = let with_eq = if b then None else Some (true,(dummy_loc,IntroAnonymous)) in - abstract_tactic (TacLetTac (na,inj_open c,cl,b)) (letin_tac with_eq na c None cl) + abstract_tactic (TacLetTac (na,c,cl,b)) (letin_tac with_eq na c None cl) (* Derived basic tactics *) let h_simple_induction_destruct isrec h = - abstract_tactic (TacSimpleInductionDestruct (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 h_induction_destruct ev isrec l = - abstract_tactic (TacInductionDestruct (isrec,ev,List.map (fun (c,e,idl,cl) -> - List.map inj_ia c,Option.map inj_open_wb e,idl,cl) l)) - (induction_destruct isrec ev l) -let h_new_induction ev c e idl cl = h_induction_destruct ev true [c,e,idl,cl] -let h_new_destruct ev c e idl cl = h_induction_destruct ev false [c,e,idl,cl] +let h_induction_destruct isrec ev lcl = + abstract_tactic (TacInductionDestruct (isrec,ev,lcl)) + (induction_destruct isrec ev lcl) +let h_new_induction ev c e idl cl = h_induction_destruct true ev ([c,e,idl],cl) +let h_new_destruct ev c e idl cl = h_induction_destruct false ev ([c,e,idl],cl) -let h_specialize n d = abstract_tactic (TacSpecialize (n,inj_open_wb d)) (specialize n d) -let h_lapply c = abstract_tactic (TacLApply (inj_open c)) (cut_and_apply c) +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)) @@ -104,34 +94,35 @@ let h_rename l = let h_revert l = abstract_tactic (TacRevert l) (revert l) (* Constructors *) -let h_left ev l = abstract_tactic (TacLeft (ev,l)) (left_with_ebindings ev l) -let h_right ev l = abstract_tactic (TacRight (ev,l)) (right_with_ebindings ev l) -let h_split ev l = abstract_tactic (TacSplit (ev,false,l)) (split_with_ebindings ev l) +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,AI n,l))(constructor_tac ev None n l) -let h_one_constructor n = h_constructor false n NoBindings +let h_one_constructor n = + abstract_tactic (TacConstructor(false,AI 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 (inj_red_expr r,cl)) (reduce r cl) -let h_change oc c cl = - abstract_tactic (TacChange (Option.map inj_occ oc,inj_open c,cl)) - (change (Option.map Redexpr.out_with_occurrences oc) c cl) +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 (inj_open c)) (intros_transitivity c) + abstract_tactic (TacTransitivity c) + (intros_transitivity c) -let h_simplest_apply c = h_apply false false [inj_open c,NoBindings] -let h_simplest_eapply c = h_apply false true [inj_open c,NoBindings] +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) diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli index 9270411a..36b0830d 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: hiddentac.mli 12102 2009-04-24 10:48:11Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names @@ -37,30 +37,30 @@ 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 -> - open_constr with_bindings list -> tactic -val h_apply_in : advanced_flag -> evars_flag -> - open_constr with_bindings list -> +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_ebindings -> - constr with_ebindings 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_ebindings -> 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 -> +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 -> +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 -> tactic (* Derived basic tactics *) @@ -68,20 +68,20 @@ val h_let_tac : letin_flag -> name -> constr -> val h_simple_induction : quantified_hypothesis -> tactic val h_simple_destruct : quantified_hypothesis -> tactic val h_simple_induction_destruct : rec_flag -> quantified_hypothesis -> tactic -val h_new_induction : evars_flag -> - constr with_ebindings induction_arg list -> constr with_ebindings option -> +val h_new_induction : evars_flag -> + constr with_bindings induction_arg list -> constr with_bindings option -> intro_pattern_expr located option * intro_pattern_expr located option -> Tacticals.clause option -> tactic -val h_new_destruct : evars_flag -> - constr with_ebindings induction_arg list -> constr with_ebindings option -> +val h_new_destruct : evars_flag -> + constr with_bindings induction_arg list -> constr with_bindings option -> intro_pattern_expr located option * intro_pattern_expr located option -> Tacticals.clause option -> tactic val h_induction_destruct : rec_flag -> evars_flag -> - (constr with_ebindings induction_arg list * constr with_ebindings option * - (intro_pattern_expr located option * intro_pattern_expr located option) * - Tacticals.clause option) list -> tactic + (constr with_bindings induction_arg list * constr with_bindings option * + (intro_pattern_expr located option * intro_pattern_expr located option)) list + * Tacticals.clause option -> tactic -val h_specialize : int option -> constr with_ebindings -> tactic +val h_specialize : int option -> constr with_bindings -> tactic val h_lapply : constr -> tactic (* Automation tactic : see Auto *) @@ -95,10 +95,10 @@ val h_rename : (identifier*identifier) list -> tactic val h_revert : identifier list -> tactic (* Constructors *) -val h_constructor : evars_flag -> int -> open_constr bindings -> tactic -val h_left : evars_flag -> open_constr bindings -> tactic -val h_right : evars_flag -> open_constr bindings -> tactic -val h_split : evars_flag -> open_constr bindings -> tactic +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 @@ -108,15 +108,15 @@ val h_simplest_right : tactic (* Conversion *) val h_reduce : Redexpr.red_expr -> Tacticals.clause -> tactic val h_change : - constr with_occurrences option -> constr -> Tacticals.clause -> tactic + Pattern.constr_pattern option -> constr -> Tacticals.clause -> tactic (* Equivalence relations *) val h_reflexivity : tactic val h_symmetry : Tacticals.clause -> tactic -val h_transitivity : constr -> tactic +val h_transitivity : constr option -> tactic -val h_simplest_apply : constr -> tactic -val h_simplest_eapply : constr -> 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 diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib new file mode 100644 index 00000000..7d12f9d0 --- /dev/null +++ b/tactics/hightactics.mllib @@ -0,0 +1,8 @@ +Refine +Extraargs +Extratactics +Eauto +Class_tactics +Rewrite +Tauto +Eqdecide diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 2e83ac70..9aec0e09 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*) -(* $Id: hipattern.ml4 11739 2009-01-02 19:33:19Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -32,10 +32,10 @@ open Declarations is an inductive but non-recursive type, a general conjuction, a general disjunction, or a type with no constructors. - They are more general than matching with or_term, and_term, etc, - since they do not depend on the name of the type. Hence, they + They are more general than matching with or_term, and_term, etc, + since they do not depend on the name of the type. Hence, they also work on ad-hoc disjunctions introduced by the user. - + -- Eduardo (6/8/97). *) type 'a matching_function = constr -> 'a option @@ -50,16 +50,16 @@ let meta4 = mkmeta 4 let op2bool = function Some _ -> true | None -> false -let match_with_non_recursive_type t = - match kind_of_term t with - | App _ -> +let match_with_non_recursive_type t = + match kind_of_term t with + | App _ -> 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 - Some (hdapp,args) - else - None + | Ind ind -> + if not (Global.lookup_mind (fst ind)).mind_finite then + Some (hdapp,args) + else + None | _ -> None) | _ -> None @@ -69,34 +69,34 @@ let is_non_recursive_type t = op2bool (match_with_non_recursive_type t) let rec has_nodep_prod_after n c = match kind_of_term c with - | Prod (_,_,b) -> - ( n>0 || not (dependent (mkRel 1) b)) + | Prod (_,_,b) -> + ( n>0 || not (dependent (mkRel 1) b)) && (has_nodep_prod_after (n-1) b) | _ -> true - + let has_nodep_prod = has_nodep_prod_after 0 -(* A general conjunctive type is a non-recursive with-no-indices inductive +(* A general conjunctive type is a non-recursive with-no-indices inductive type with only one constructor and no dependencies between argument; - it is strict if it has the form + it is strict if it has the form "Inductive I A1 ... An := C (_:A1) ... (_:An)" *) (* style: None = record; Some false = conjunction; Some true = strict conj *) -let match_with_one_constructor style t = - let (hdapp,args) = decompose_app t in +let match_with_one_constructor style allow_rec t = + let (hdapp,args) = decompose_app t in match kind_of_term hdapp with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in if (Array.length mip.mind_consnames = 1) - && (not (mis_is_recursive (ind,mib,mip))) + && (allow_rec or not (mis_is_recursive (ind,mib,mip))) && (mip.mind_nrealargs = 0) then if style = Some true (* strict conjunction *) then - let ctx = - fst (decompose_prod_assum (snd + let ctx = + (prod_assum (snd (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in - if + if List.for_all (fun (_,b,c) -> b=None && c = mkRel mib.mind_nparams) ctx then @@ -104,7 +104,7 @@ let match_with_one_constructor style t = else None else let ctyp = prod_applist mip.mind_nf_lc.(0) args in - let cargs = List.map pi3 (fst (decompose_prod_assum ctyp)) in + let cargs = List.map pi3 ((prod_assum ctyp)) in if style <> Some false || has_nodep_prod ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) @@ -115,10 +115,10 @@ let match_with_one_constructor style t = | _ -> None let match_with_conjunction ?(strict=false) t = - match_with_one_constructor (Some strict) t + match_with_one_constructor (Some strict) false t -let match_with_record t = - match_with_one_constructor None t +let match_with_record t = + match_with_one_constructor None false t let is_conjunction ?(strict=false) t = op2bool (match_with_conjunction ~strict t) @@ -126,20 +126,30 @@ let is_conjunction ?(strict=false) 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 + 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 + (hd,l,isrec)) t + +let is_tuple t = + op2bool (match_with_tuple t) -(* A general disjunction type is a non-recursive with-no-indices inductive +(* A general disjunction type is a non-recursive with-no-indices inductive type with of which all constructors have a single argument; - it is strict if it has the form + it is strict if it has the form "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *) let test_strict_disjunction n lc = array_for_all_i (fun i c -> - match fst (decompose_prod_assum (snd (decompose_prod_n_assum n c))) with + match (prod_assum (snd (decompose_prod_n_assum n c))) with | [_,None,c] -> c = mkRel (n - i) | _ -> false) 0 lc let match_with_disjunction ?(strict=false) t = - let (hdapp,args) = decompose_app t in + let (hdapp,args) = decompose_app t in match kind_of_term hdapp with | Ind ind -> let car = mis_constr_nargs ind in @@ -157,7 +167,7 @@ let match_with_disjunction ?(strict=false) t = Array.map (fun ar -> pi2 (destProd (prod_applist ar args))) mip.mind_nf_lc in Some (hdapp,Array.to_list cargs) - else + else None | _ -> None @@ -170,12 +180,12 @@ let is_disjunction ?(strict=false) t = let match_with_empty_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in - let nconstr = Array.length mip.mind_consnames in + let nconstr = Array.length mip.mind_consnames in if nconstr = 0 then Some hdapp else None | _ -> None - + let is_empty_type t = op2bool (match_with_empty_type t) (* This filters inductive types with one constructor with no arguments; @@ -184,21 +194,22 @@ let is_empty_type t = op2bool (match_with_empty_type t) let match_with_unit_or_eq_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in - let constr_types = mip.mind_nf_lc 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 = nb_prod c = mib.mind_nparams in + if nconstr = 1 && zero_args constr_types.(0) then Some hdapp - else + else None | _ -> None let is_unit_or_eq_type t = op2bool (match_with_unit_or_eq_type t) (* A unit type is an inductive type with no indices but possibly - (useless) parameters, and that has no constructors *) + (useless) parameters, and that has no arguments in its unique + constructor *) let is_unit_type t = match match_with_conjunction t with @@ -209,75 +220,94 @@ let is_unit_type t = inductive binary relation R, so that R has only one constructor establishing its reflexivity. *) -let coq_refl_rel1_pattern = PATTERN [ forall A:_, forall x:A, _ A x x ] -let coq_refl_rel2_pattern = PATTERN [ forall x:_, _ x x ] -let coq_refl_reljm_pattern = PATTERN [ forall A:_, forall x:A, _ A x A x ] +type equation_kind = + | MonomorphicLeibnizEq of constr * constr + | PolymorphicLeibnizEq of constr * constr * constr + | HeterogenousEq of constr * constr * constr * constr + +exception NoEquationFound + +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 let match_with_equation t = - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with - | Ind ind -> + 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 + Some (build_coq_eq_data()),hdapp, + PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if 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 + 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 constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in - if nconstr = 1 && - (is_matching coq_refl_rel1_pattern constr_types.(0) || - is_matching coq_refl_rel2_pattern constr_types.(0) || - is_matching coq_refl_reljm_pattern constr_types.(0)) - then - Some (hdapp,args) - else - None - | _ -> None - -let is_equation t = op2bool (match_with_equation t) + if 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 + None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if is_matching coq_refl_jm_pattern constr_types.(0) then + None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) + else raise NoEquationFound + else raise NoEquationFound + | _ -> raise NoEquationFound + +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 let match_with_equality_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind when args <> [] -> - let (mib,mip) = Global.lookup_inductive ind in - let nconstr = Array.length mip.mind_consnames in - if nconstr = 1 && constructor_nrealargs (Global.env()) (ind,1) = 0 - then - Some (hdapp,args) - else - None - | _ -> None + | Ind ind when is_inductive_equality ind -> Some (hdapp,args) + | _ -> None + +let is_equality_type t = op2bool (match_with_equality_type t) 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" + | _ -> anomaly "Incorrect pattern matching" let match_with_nottype t = try let (arg,mind) = match_arrow_pattern t in if is_empty_type mind then Some (mind,arg) else None - with PatternMatchingFailure -> None + with PatternMatchingFailure -> None let is_nottype t = op2bool (match_with_nottype t) - + let match_with_forall_term c= match kind_of_term c with | Prod (nam,a,b) -> Some (nam,a,b) | _ -> None -let is_forall_term c = op2bool (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 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 -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in if Array.length (mib.mind_packets)>1 then None else let nodep_constr = has_nodep_prod_after mib.mind_nparams in @@ -286,24 +316,24 @@ let match_with_nodep_ind t = if mip.mind_nrealargs=0 then args else fst (list_chop mib.mind_nparams args) in Some (hdapp,params,mip.mind_nrealargs) - else + else None | _ -> None - + let is_nodep_ind t=op2bool (match_with_nodep_ind t) let match_with_sigma_type t= let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | 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) && has_nodep_prod_after (mib.mind_nparams+1) mip.mind_nf_lc.(0) then - (*allowing only 1 existential*) + (*allowing only 1 existential*) Some (hdapp,args) - else + else None | _ -> None @@ -323,21 +353,58 @@ let rec first_match matcher = function 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 = - match matches (Lazy.force eq_pat) eqn with + let pat = try Lazy.force eq_pat with _ -> raise PatternMatchingFailure in + match matches pat eqn with | [(m1,t);(m2,x);(m3,y)] -> assert (m1 = meta1 & m2 = meta2 & m3 = meta3); - (t,x,y) - | _ -> anomaly "match_eq: an eq pattern should match 3 terms" + PolymorphicLeibnizEq (t,x,y) + | [(m1,t);(m2,x);(m3,t');(m4,x')] -> + assert (m1 = meta1 & m2 = meta2 & m3 = meta3 & m4 = meta4); + HeterogenousEq (t,x,t',x') + | _ -> anomaly "match_eq: an eq pattern should match 3 or 4 terms" let equalities = [coq_eq_pattern, build_coq_eq_data; + coq_jmeq_pattern, build_coq_jmeq_data; coq_identity_pattern, build_coq_identity_data] -let find_eq_data_decompose eqn = (* fails with PatternMatchingFailure *) +let find_eq_data eqn = (* fails with PatternMatchingFailure *) first_match (match_eq eqn) equalities +let extract_eq_args gl = function + | MonomorphicLeibnizEq (e1,e2) -> + let t = Tacmach.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) + 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 find_this_eq_data_decompose gl eqn = + let (lbeq,eq_args) = + try (*first_match (match_eq eqn) inversible_equalities*) + find_eq_data eqn + with PatternMatchingFailure -> + errorlabstrm "" (str "No primitive equality found.") in + let eq_args = + 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 @@ -369,7 +436,7 @@ let match_sigma ex ex_pat = anomaly "match_sigma: a successful sigma pattern should match 4 terms" let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) - first_match (match_sigma ex) + first_match (match_sigma ex) [coq_existT_pattern, build_sigma_type] (* Pattern "(sig ?1 ?2)" *) @@ -407,14 +474,14 @@ let op_sum = coq_sumbool_ref let match_eqdec t = let eqonleft,op,subst = try true,op_sum,matches (Lazy.force coq_eqdec_inf_pattern) t - with PatternMatchingFailure -> + with PatternMatchingFailure -> try false,op_sum,matches (Lazy.force coq_eqdec_inf_rev_pattern) t - with PatternMatchingFailure -> + with PatternMatchingFailure -> try true,op_or,matches (Lazy.force coq_eqdec_pattern) t - with PatternMatchingFailure -> + with PatternMatchingFailure -> false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in match subst with - | [(_,typ);(_,c1);(_,c2)] -> + | [(_,typ);(_,c1);(_,c2)] -> eqonleft, Libnames.constr_of_global (Lazy.force op), c1, c2, typ | _ -> anomaly "Unexpected pattern" diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 3c423202..d98d2a2b 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: hipattern.mli 11739 2009-01-02 19:33:19Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Util @@ -16,6 +16,7 @@ open Sign open Evd open Pattern open Proof_trees +open Coqlib (*i*) (*s Given a term with second-order variables in it, @@ -41,8 +42,8 @@ open Proof_trees is an inductive but non-recursive type, a general conjuction, a general disjunction, or a type with no constructors. - They are more general than matching with [or_term], [and_term], etc, - since they do not depend on the name of the type. Hence, they + They are more general than matching with [or_term], [and_term], etc, + since they do not depend on the name of the type. Hence, they also work on ad-hoc disjunctions introduced by the user. (Eduardo, 6/8/97). *) @@ -50,41 +51,50 @@ type 'a matching_function = constr -> 'a option type testing_function = constr -> bool val match_with_non_recursive_type : (constr * constr list) matching_function -val is_non_recursive_type : testing_function +val is_non_recursive_type : testing_function +(* Non recursive type with no indices and exactly one argument for each + constructor; canonical definition of n-ary disjunction if strict *) val match_with_disjunction : ?strict:bool -> (constr * constr list) matching_function -val is_disjunction : ?strict:bool -> testing_function +val is_disjunction : ?strict: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 is_conjunction : ?strict:bool -> testing_function +(* Non recursive tuple, possibly with inner dependencies *) val match_with_record : (constr * constr list) matching_function -val is_record : testing_function +val is_record : testing_function + +(* Like record but supports and tells if recursive (e.g. Acc) *) +val match_with_tuple : (constr * constr list * bool) matching_function +val is_tuple : testing_function +(* No constructor, possibly with indices *) val match_with_empty_type : constr matching_function -val is_empty_type : testing_function +val is_empty_type : testing_function (* type with only one constructor and no arguments, possibly with indices *) val match_with_unit_or_eq_type : constr matching_function -val is_unit_or_eq_type : testing_function +val is_unit_or_eq_type : testing_function (* type with only one constructor and no arguments, no indices *) -val is_unit_type : testing_function - -val match_with_equation : (constr * constr list) matching_function -val is_equation : testing_function +val is_unit_type : testing_function (* type with only one constructor, no arguments and at least one dependency *) +val is_inductive_equality : inductive -> bool val match_with_equality_type : (constr * constr list) matching_function +val is_equality_type : testing_function val match_with_nottype : (constr * constr) matching_function -val is_nottype : testing_function +val is_nottype : testing_function val match_with_forall_term : (name * constr * constr) matching_function -val is_forall_term : testing_function +val is_forall_term : testing_function val match_with_imp_term : (constr * constr) matching_function -val is_imp_term : testing_function +val is_imp_term : testing_function (* I added these functions to test whether a type contains dependent products or not, and if an inductive has constructors with dependent types @@ -94,24 +104,41 @@ val is_imp_term : testing_function val has_nodep_prod_after : int -> testing_function val has_nodep_prod : testing_function -val match_with_nodep_ind : (constr * constr list * int) matching_function -val is_nodep_ind : testing_function +val match_with_nodep_ind : (constr * constr list * int) matching_function +val is_nodep_ind : testing_function + +val match_with_sigma_type : (constr * constr list) matching_function +val is_sigma_type : testing_function + +(* Recongnize inductive relation defined by reflexivity *) -val match_with_sigma_type : (constr * constr list) matching_function -val is_sigma_type : testing_function +type equation_kind = + | MonomorphicLeibnizEq of constr * constr + | PolymorphicLeibnizEq of constr * constr * constr + | HeterogenousEq of constr * constr * constr * constr + +exception NoEquationFound + +val match_with_equation: + constr -> coq_eq_data option * constr * equation_kind (***** Destructing patterns bound to some theory *) -open Coqlib +(* Match terms [eq A t u], [identity A t u] or [JMeq A t A u] *) +(* Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) +val find_eq_data_decompose : Proof_type.goal sigma -> constr -> + coq_eq_data * (types * constr * constr) + +(* Idem but fails with an error message instead of PatternMatchingFailure *) +val find_this_eq_data_decompose : Proof_type.goal sigma -> constr -> + coq_eq_data * (types * constr * constr) -(* Match terms [(eq A t u)] or [(identity A t u)] *) -(* Returns associated lemmas and [A,t,u] *) -val find_eq_data_decompose : constr -> - coq_leibniz_eq_data * (constr * constr * constr) +(* A variant that returns more informative structure on the equality found *) +val find_eq_data : constr -> coq_eq_data * equation_kind (* Match a term of the form [(existT A P t p)] *) (* Returns associated lemmas and [A,P,t,p] *) -val find_sigma_data_decompose : constr -> +val find_sigma_data_decompose : constr -> coq_sigma_data * (constr * constr * constr * constr) (* Match a term of the form [{x:A|P}], returns [A] and [P] *) diff --git a/tactics/inv.ml b/tactics/inv.ml index af204e77..86641114 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: inv.ml 12410 2009-10-24 17:23:39Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -14,6 +14,7 @@ open Names open Nameops open Term open Termops +open Namegen open Global open Sign open Environ @@ -37,21 +38,22 @@ open Rawterm open Genarg open Tacexpr -let collect_meta_variables c = +let collect_meta_variables c = let rec collrec acc c = match kind_of_term c with | Meta mv -> mv::acc | _ -> fold_constr collrec acc c - in + in collrec [] c let check_no_metas clenv ccl = if occur_meta ccl then - let metas = List.filter (fun na -> na<>Anonymous) - (List.map (Evd.meta_name clenv.evd) (collect_meta_variables ccl)) in - errorlabstrm "inversion" + 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_coma pr_name metas + prlist_with_sep pr_comma pr_name metas (* ajouter "in " ++ pr_lconstr ccl mais il faut le bon contexte *)) let var_occurs_in_pf gl id = @@ -60,7 +62,7 @@ let var_occurs_in_pf gl id = List.exists (occur_var_in_decl env id) (pf_hyps gl) (* [make_inv_predicate (ity,args) C] - + is given the inductive type, its arguments, both the global parameters and its local arguments, and is expected to produce a predicate P such that if largs is the "local" part of the @@ -127,16 +129,16 @@ let make_inv_predicate env sigma indf realargs id status concl = push <Ai>(mkRel k)=ai (when Ai is closed). In any case, we carry along the rest of pairs *) let rec build_concl eqns n = function - | [] -> (prod_it concl eqns,n) + | [] -> (it_mkProd concl eqns,n) | (ai,(xi,ti))::restlist -> let (lhs,eqnty,rhs) = - if closed0 ti then + if closed0 ti then (xi,ti,ai) - else + else make_iterated_tuple env' sigma ai (xi,ti) in let eq_term = Coqlib.build_coq_eq () in - let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in + let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist in let (newconcl,neqns) = build_concl [] 0 pairs in @@ -188,21 +190,21 @@ let make_inv_predicate env sigma indf realargs id status concl = it generalizes them, applies tac to rewrite all occurrencies of t, and introduces generalized hypotheis. Precondition: t=(mkVar id) *) - -let rec dependent_hyps id idlist gl = + +let rec dependent_hyps id idlist gl = let rec dep_rec =function | [] -> [] - | (id1,_,_)::l -> + | (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 then d :: dep_rec l else dep_rec l - in - dep_rec idlist + in + dep_rec idlist let split_dep_and_nodep hyps gl = - List.fold_right + List.fold_right (fun (id,_,_ as d) (l1,l2) -> if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2)) hyps ([],[]) @@ -280,17 +282,17 @@ Summary: nine useless hypotheses! Nota: with Inversion_clear, only four useless hypotheses *) -let generalizeRewriteIntros tac depids id gls = +let generalizeRewriteIntros tac depids id gls = let dids = dependent_hyps id depids gls in (tclTHENSEQ - [bring_hyps dids; tac; + [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 -> + | a::l -> if n=0 then error "Too many names." else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l) @@ -317,14 +319,14 @@ let projectAndApply thin id eqname names depids gls = | _ -> tac id gls in let deq_trailer id neqns = - tclTHENSEQ + tclTHENSEQ [(if names <> [] then clear [id] else tclIDTAC); (tclMAP_i neqns (fun idopt -> - tclTHEN + tclTRY (tclTHEN (intro_move idopt no_move) (* try again to substitute and if still not a variable after *) (* decomposition, arbitrarily try to rewrite RL !? *) - (tclTRY (onLastHyp (substHypIfVariable (subst_hyp false))))) + (tclTRY (onLastHypId (substHypIfVariable (subst_hyp false)))))) names); (if names = [] then clear [id] else tclIDTAC)] in @@ -342,14 +344,14 @@ let rewrite_equations_gene othin neqns ba gl = let rewrite_eqns = match othin with | Some thin -> - onLastHyp + onLastHypId (fun last -> tclTHENSEQ [tclDO neqns (tclTHEN intro - (onLastHyp + (onLastHypId (fun id -> - tclTRY + tclTRY (projectAndApply thin id (ref no_move) [] depids)))); onHyps (compose List.rev (afterHyp last)) bring_hyps; @@ -361,8 +363,8 @@ let rewrite_equations_gene othin neqns ba gl = [tclDO neqns intro; bring_hyps nodepids; clear (ids_of_named_context nodepids); - onHyps (compose List.rev (nLastHyps neqns)) bring_hyps; - onHyps (nLastHyps neqns) (compose clear ids_of_named_context); + 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]) @@ -378,13 +380,13 @@ let rewrite_equations_gene othin neqns ba gl = let rec get_names allow_conj (loc,pat) = match pat with | IntroWildcard -> error "Discarding pattern not allowed for inversion equations." - | IntroAnonymous -> + | 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] -> + | 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 @@ -408,13 +410,13 @@ let rewrite_equations othin neqns names ba gl = match othin with | Some thin -> tclTHENSEQ - [onHyps (compose List.rev (nLastHyps neqns)) bring_hyps; - onHyps (nLastHyps neqns) (compose clear ids_of_named_context); + [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 (tclTHEN (intro_move idopt no_move) - (onLastHyp (fun id -> + (onLastHypId (fun id -> tclTRY (projectAndApply thin id first_eq names depids))))) names; tclMAP (fun (id,_,_) gl -> @@ -440,18 +442,18 @@ let rewrite_equations_tac (gene, othin) id neqns names ba = 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 + if othin = Some true (* if Inversion_clear, clear the hypothesis *) then tclTHEN tac (tclTRY (clear [id])) - else + 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) = + let (ind,t) = try pf_reduce_to_atomic_ind gl (pf_type_of gl c) - with UserError _ -> + 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 @@ -461,19 +463,19 @@ let raw_inversion inv_kind id status names gl = 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 + if status <> NoDep & (dependent c (pf_concl gl)) then Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), - case_then_using - else + case_then_using + else Reduction.beta_appvect elim_predicate (Array.of_list realargs), - case_nodep_then_using + case_nodep_then_using in (tclTHENS (assert_tac Anonymous cut_concl) - [case_tac names + [case_tac names (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns)) (Some elim_predicate) ([],[]) ind indclause; - onLastHyp + onLastHypId (fun id -> (tclTHEN (apply_term (mkVar id) @@ -487,7 +489,7 @@ let wrap_inv_error id = function (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) -> errorlabstrm "" (strbrk "Inversion would require case analysis on sort " ++ - pr_sort k ++ + pr_sort k ++ strbrk " which is not allowed for inductive definition " ++ pr_inductive (Global.env()) i ++ str ".") | e -> raise e @@ -526,16 +528,16 @@ let invIn k names ids id gls = let intros_replace_ids gls = let nb_of_new_hyp = nb_prod (pf_concl gls) - (List.length hyps + nb_prod_init) - in - if nb_of_new_hyp < 1 then + in + if nb_of_new_hyp < 1 then intros_replacing ids gls - else + else tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) gls in - try + try (tclTHENSEQ [bring_hyps hyps; - inversion (false,k) NoDep names id; + inversion (false,k) NoDep names id; intros_replace_ids]) gls with e -> wrap_inv_error id e diff --git a/tactics/inv.mli b/tactics/inv.mli index bbb2a322..8ec0e2db 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: inv.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Util @@ -24,7 +24,7 @@ val inv_gen : bool -> inversion_kind -> inversion_status -> intro_pattern_expr located option -> quantified_hypothesis -> tactic val invIn_gen : - inversion_kind -> intro_pattern_expr located option -> identifier list -> + inversion_kind -> intro_pattern_expr located option -> identifier list -> quantified_hypothesis -> tactic val inv_clause : diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 4cbfa6c2..1f08969f 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: leminv.ml 13126 2010-06-13 11:09:51Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -14,6 +14,7 @@ open Names open Nameops open Term open Termops +open Namegen open Sign open Evd open Printer @@ -39,7 +40,7 @@ open Decl_kinds let not_work_message = "tactic fails to build the inversion lemma, may be because the predicate has arguments that depend on other arguments" let no_inductive_inconstr env constr = - (str "Cannot recognize an inductive predicate in " ++ + (str "Cannot recognize an inductive predicate in " ++ pr_lconstr_env env constr ++ str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++ spc () ++ str "or of the type of constructors" ++ spc () ++ @@ -87,7 +88,7 @@ let no_inductive_inconstr env constr = the respective assumption in each subgoal. *) - + let thin_ids env (hyps,vars) = fst (List.fold_left @@ -106,16 +107,16 @@ let thin_ids env (hyps,vars) = let get_local_sign sign = let lid = ids_of_sign sign in let globsign = Global.named_context() in - let add_local id res_sign = - if not (mem_sign globsign id) then + let add_local id res_sign = + if not (mem_sign globsign id) then add_sign (lookup_sign id sign) res_sign - else + else res_sign - in + in List.fold_right add_local lid nil_sign *) (* returs the identifier of lid that was the latest declared in sign. - * (i.e. is the identifier id of lid such that + * (i.e. is the identifier id of lid such that * sign_length (sign_prefix id sign) > sign_length (sign_prefix id' sign) > * for any id'<>id in lid). * it returns both the pair (id,(sign_prefix id sign)) *) @@ -123,14 +124,14 @@ let get_local_sign sign = let max_prefix_sign lid sign = let rec max_rec (resid,prefix) = function | [] -> (resid,prefix) - | (id::l) -> - let pre = sign_prefix id sign in - if sign_length pre > sign_length prefix then + | (id::l) -> + let pre = sign_prefix id sign in + if sign_length pre > sign_length prefix then max_rec (id,pre) l - else + else max_rec (resid,prefix) l in - match lid with + match lid with | [] -> nil_sign | id::l -> snd (max_rec (id, sign_prefix id sign) l) *) @@ -148,14 +149,14 @@ let rec add_prods_sign env sigma t = (* [dep_option] indicates wether the inversion lemma is dependent or not. If it is dependent and I is of the form (x_bar:T_bar)(I t_bar) then - the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) + the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) where P:(x_bar:T_bar)(H:(I x_bar))[sort]. The generalisation of such a goal at the moment of the dependent case should be easy. If it is non dependent, then if [I]=(I t_bar) and (x_bar:T_bar) are the variables occurring in [I], then the stated goal will be: - (x_bar:T_bar)(I t_bar)->(P x_bar) + (x_bar:T_bar)(I t_bar)->(P x_bar) where P: P:(x_bar:T_bar)[sort]. *) @@ -166,7 +167,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let pty,goal = if dep_option then let pty = make_arity env true indf sort in - let goal = + let goal = mkProd (Anonymous, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) in @@ -177,11 +178,11 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let revargs,ownsign = fold_named_context (fun env (id,_,_ as d) (revargs,hyps) -> - if List.mem id ivars then + if List.mem id ivars then ((mkVar id)::revargs,add_named_decl d hyps) - else + else (revargs,hyps)) - env ~init:([],[]) + env ~init:([],[]) in let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in @@ -191,6 +192,10 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let extenv = push_named (p,None,npty) env in extenv, goal +let whd_meta_from_map metamap c = match kind_of_term c with + | Meta p -> (try List.assoc p metamap with Not_found -> c) + | _ -> c + (* [inversion_scheme sign I] Given a local signature, [sign], and an instance of an inductive @@ -203,14 +208,14 @@ let inversion_scheme env sigma t sort dep_option inv_op = let ind = try find_rectype env sigma i with Not_found -> - errorlabstrm "inversion_scheme" (no_inductive_inconstr env i) + errorlabstrm "inversion_scheme" (no_inductive_inconstr env i) in let (invEnv,invGoal) = - compute_first_inversion_scheme env sigma ind sort dep_option + compute_first_inversion_scheme env sigma ind sort dep_option in - assert - (list_subset - (global_vars env invGoal) + assert + (list_subset + (global_vars env invGoal) (ids_of_named_context (named_context invEnv))); (* errorlabstrm "lemma_inversion" @@ -218,7 +223,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = *) let invSign = named_context_val invEnv in let pfs = mk_pftreestate (mk_goal invSign invGoal None) in - let pfs = solve_pftreestate (tclTHEN intro (onLastHyp inv_op)) pfs in + let pfs = solve_pftreestate (tclTHEN intro (onLastHypId inv_op)) pfs in let (pfterm,meta_types) = extract_open_pftreestate pfs in let global_named_context = Global.named_context () in let ownSign = @@ -226,7 +231,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = (fun env (id,_,_ as d) sign -> if mem_named_context id global_named_context then sign else add_named_decl d sign) - invEnv ~init:empty_named_context + invEnv ~init:empty_named_context in let (_,ownSign,mvb) = List.fold_left @@ -234,23 +239,23 @@ let inversion_scheme env sigma t sort dep_option inv_op = let h = next_ident_away (id_of_string "H") avoid in (h::avoid, add_named_decl (h,None,mvty) sign, (mv,mkVar h)::mvb)) (ids_of_context invEnv, ownSign, []) - meta_types + meta_types in - let invProof = + let invProof = it_mkNamedLambda_or_LetIn - (local_strong (fun _ -> whd_meta mvb) Evd.empty pfterm) ownSign + (local_strong (fun _ -> whd_meta_from_map mvb) Evd.empty pfterm) ownSign in invProof let add_inversion_lemma name env sigma t sort dep inv_op = let invProof = inversion_scheme env sigma t sort dep inv_op in - let _ = + let _ = declare_constant name - (DefinitionEntry + (DefinitionEntry { const_entry_body = invProof; const_entry_type = None; const_entry_opaque = false; - const_entry_boxed = true && (Flags.boxed_definitions())}, + const_entry_boxed = true && (Flags.boxed_definitions())}, IsProof Lemma) in () @@ -262,11 +267,11 @@ let add_inversion_lemma name env sigma t sort dep inv_op = let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op = let pts = get_pftreestate() in let gl = nth_goal_of_pftreestate n pts in - let t = + let t = try pf_get_hyp_typ gl id with Not_found -> Pretype_errors.error_var_not_found_loc loc id in let env = pf_env gl and sigma = project gl in -(* Pourquoi ??? +(* Pourquoi ??? let fv = global_vars env t in let thin_ids = thin_ids (hyps,fv) in if not(list_subset thin_ids fv) then @@ -275,14 +280,14 @@ let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op = str"free variables in the types of an inductive" ++ spc () ++ str"which are not free in its instance."); *) add_inversion_lemma na env sigma t sort dep_option inv_op - + let add_inversion_lemma_exn na com comsort bool tac = let env = Global.env () and sigma = Evd.empty in let c = Constrintern.interp_type sigma env com in let sort = Pretyping.interp_sort comsort in try add_inversion_lemma na env sigma c sort bool tac - with + with | UserError ("Case analysis",s) -> (* référence à Indrec *) errorlabstrm "Inv needs Nodep Prop Set" s @@ -296,26 +301,26 @@ let lemInv id c gls = let clause = mk_clenv_type_of gls c in let clause = clenv_constrain_last_binding (mkVar id) clause in Clenvtac.res_pf clause ~allow_K:true gls - with + with | NoSuchBinding -> errorlabstrm "" (hov 0 (pr_constr c ++ spc () ++ str "does not refer to an inversion lemma.")) - | UserError (a,b) -> - errorlabstrm "LemInv" - (str "Cannot refine current goal with the lemma " ++ - pr_lconstr_env (Global.env()) c) + | UserError (a,b) -> + errorlabstrm "LemInv" + (str "Cannot refine current goal with the lemma " ++ + pr_lconstr_env (Global.env()) c) let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id let lemInvIn id c ids gls = let hyps = List.map (pf_get_hyp gls) ids in let intros_replace_ids gls = - let nb_of_new_hyp = nb_prod (pf_concl gls) - List.length ids in - if nb_of_new_hyp < 1 then + let nb_of_new_hyp = nb_prod (pf_concl gls) - List.length ids in + if nb_of_new_hyp < 1 then intros_replacing ids gls - else + else (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)) gls - in + in ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c)) (intros_replace_ids)) gls) diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 3e12f770..b4b5737b 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -8,7 +8,7 @@ open Topconstr val lemInv_gen : quantified_hypothesis -> constr -> tactic val lemInvIn_gen : quantified_hypothesis -> constr -> identifier list -> tactic -val lemInv_clause : +val lemInv_clause : quantified_hypothesis -> constr -> identifier list -> tactic val inversion_lemma_from_goal : diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml index b94ae2dd..7d6e1c4c 100644 --- a/tactics/nbtermdn.ml +++ b/tactics/nbtermdn.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: nbtermdn.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id$ *) open Util open Names @@ -26,63 +26,123 @@ open Libnames (* The former comments are from Chet. See the module dn.ml for further explanations. Eduardo (5/8/97) *) +module Make = + functor (Y:Map.OrderedType) -> +struct + module X = struct + type t = constr_pattern*int + let compare = Pervasives.compare + end + + module Term_dn = Termdn.Make(Y) + open Term_dn + module Z = struct + type t = Term_dn.term_label + let compare x y = + let make_name n = + match n with + | GRLabel(ConstRef con) -> + GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | GRLabel(IndRef (kn,i)) -> + GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | GRLabel(ConstructRef ((kn,i),j ))-> + GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + module Dn = Dn.Make(X)(Z)(Y) + module Bounded_net = Btermdn.Make(Y) + + +type 'na t = { + mutable table : ('na,constr_pattern * Y.t) Gmap.t; + mutable patterns : (Term_dn.term_label option,Bounded_net.t) Gmap.t } -type ('na,'a) t = { - mutable table : ('na,constr_pattern * 'a) Gmap.t; - mutable patterns : (global_reference option,'a Btermdn.t) Gmap.t } -type ('na,'a) frozen_t = - ('na,constr_pattern * 'a) Gmap.t - * (global_reference option,'a Btermdn.t) Gmap.t +type 'na frozen_t = + ('na,constr_pattern * Y.t) Gmap.t + * (Term_dn.term_label option, Bounded_net.t) Gmap.t let create () = { table = Gmap.empty; patterns = Gmap.empty } let get_dn dnm hkey = - try Gmap.find hkey dnm with Not_found -> Btermdn.create () + try Gmap.find hkey dnm with Not_found -> Bounded_net.create () let add dn (na,(pat,valu)) = - let hkey = Option.map fst (Termdn.constr_pat_discr pat) in + let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in dn.table <- Gmap.add na (pat,valu) dn.table; let dnm = dn.patterns in - dn.patterns <- Gmap.add hkey (Btermdn.add None (get_dn dnm hkey) (pat,valu)) dnm - + dn.patterns <- Gmap.add hkey (Bounded_net.add None (get_dn dnm hkey) (pat,valu)) dnm + let rmv dn na = let (pat,valu) = Gmap.find na dn.table in - let hkey = Option.map fst (Termdn.constr_pat_discr pat) in + let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in dn.table <- Gmap.remove na dn.table; let dnm = dn.patterns in - dn.patterns <- Gmap.add hkey (Btermdn.rmv None (get_dn dnm hkey) (pat,valu)) dnm + dn.patterns <- Gmap.add hkey (Bounded_net.rmv None (get_dn dnm hkey) (pat,valu)) dnm let in_dn dn na = Gmap.mem na dn.table - + let remap ndn na (pat,valu) = rmv ndn na; add ndn (na,(pat,valu)) +let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] + + let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Const _ -> Dn.Everything + | _ -> Dn.Nothing + +let 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 s -> Dn.Label(Term_dn.SortLabel (Some s), []) + | Evar _ -> Dn.Everything + | _ -> Dn.Nothing + let lookup dn valu = - let hkey = - match (Termdn.constr_val_discr valu) with + let hkey = + match (constr_val_discr valu) with | Dn.Label(l,_) -> Some l | _ -> None - in - try Btermdn.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> [] + in + try Bounded_net.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> [] let app f dn = Gmap.iter f dn.table - + let dnet_depth = Btermdn.dnet_depth - + let freeze dn = (dn.table, dn.patterns) let unfreeze (fnm,fdnm) dn = dn.table <- fnm; dn.patterns <- fdnm -let empty dn = +let empty dn = dn.table <- Gmap.empty; dn.patterns <- Gmap.empty -let to2lists dn = +let to2lists dn = (Gmap.to_list dn.table, Gmap.to_list dn.patterns) - +end diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli index 579b24d4..027ea573 100644 --- a/tactics/nbtermdn.mli +++ b/tactics/nbtermdn.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: nbtermdn.mli 6427 2004-12-07 17:41:10Z sacerdot $ i*) +(*i $Id$ i*) (*i*) open Term @@ -15,24 +15,37 @@ open Libnames (*i*) (* Named, bounded-depth, term-discrimination nets. *) - -type ('na,'a) t -type ('na,'a) frozen_t - -val create : unit -> ('na,'a) t - -val add : ('na,'a) t -> ('na * (constr_pattern * 'a)) -> unit -val rmv : ('na,'a) t -> 'na -> unit -val in_dn : ('na,'a) t -> 'na -> bool -val remap : ('na,'a) t -> 'na -> (constr_pattern * 'a) -> unit - -val lookup : ('na,'a) t -> constr -> (constr_pattern * 'a) list -val app : ('na -> (constr_pattern * 'a) -> unit) -> ('na,'a) t -> unit - -val dnet_depth : int ref - -val freeze : ('na,'a) t -> ('na,'a) frozen_t -val unfreeze : ('na,'a) frozen_t -> ('na,'a) t -> unit -val empty : ('na,'a) t -> unit -val to2lists : ('na,'a) t -> ('na * (constr_pattern * 'a)) list * - (global_reference option * 'a Btermdn.t) list +module Make : + functor (Y:Map.OrderedType) -> +sig + + module Term_dn : sig + type term_label = + | GRLabel of global_reference + | ProdLabel + | LambdaLabel + | SortLabel of sorts option + end + + type 'na t + type 'na frozen_t + + val create : unit -> 'na t + + val add : 'na t -> ('na * (constr_pattern * Y.t)) -> unit + val rmv : 'na t -> 'na -> unit + val in_dn : 'na t -> 'na -> bool + val remap : 'na t -> 'na -> (constr_pattern * Y.t) -> unit + + val lookup : 'na t -> constr -> (constr_pattern * Y.t) list + val app : ('na -> (constr_pattern * Y.t) -> unit) -> 'na t -> unit + + val dnet_depth : int ref + + + val freeze : 'na t -> 'na frozen_t + val unfreeze : 'na frozen_t -> 'na t -> unit + val empty : 'na t -> unit + val to2lists : 'na t -> ('na * (constr_pattern * Y.t)) list * + (Term_dn.term_label option * Btermdn.Make(Y).t) list +end diff --git a/tactics/refine.ml b/tactics/refine.ml index ff3f0887..cbca38d0 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: refine.ml 13129 2010-06-13 14:23:55Z herbelin $ *) +(* $Id$ *) (* JCF -- 6 janvier 1998 EXPERIMENTAL *) @@ -16,19 +16,19 @@ * où les trous sont typés -- et que les sous-buts correspondants * soient engendrés pour finir la preuve. * - * Exemple : + * Exemple : * J'ai le but - * (x:nat) { y:nat | (minus y x) = x } + * forall (x:nat), { y:nat | (minus y x) = x } * et je donne la preuve incomplète - * [x:nat](exist nat [y:nat]((minus y x)=x) (plus x x) ?) + * fun (x:nat) => exist nat [y:nat]((minus y x)=x) (plus x x) ? * ce qui engendre le but - * (minus (plus x x) x)=x + * (minus (plus x x) x) = x *) (* Pour cela, on procède de la manière suivante : * * 1. Un terme de preuve incomplet est un terme contenant des variables - * existentielles Evar i.e. "?" en syntaxe concrète. + * existentielles Evar i.e. "_" en syntaxe concrète. * La résolution de ces variables n'est plus nécessairement totale * (ise_resolve called with fail_evar=false) et les variables * existentielles restantes sont remplacées par des méta-variables @@ -38,8 +38,10 @@ * 2. On met ensuite le terme "à plat" i.e. on n'autorise des MV qu'au * permier niveau et pour chacune d'elles, si nécessaire, on donne * à son tour un terme de preuve incomplet pour la résoudre. - * Exemple: le terme (f a ? [x:nat](e ?)) donne - * (f a ?1 ?2) avec ?2 => [x:nat]?3 et ?3 => (e ?4) + * Exemple: le terme (f a _ (fun (x:nat) => e _)) donne + * (f a ?1 ?2) avec: + * - ?2 := fun (x:nat) => ?3 + * - ?3 := e ?4 * ?1 et ?4 donneront des buts * * 3. On écrit ensuite une tactique tcc qui engendre les sous-buts @@ -51,6 +53,7 @@ open Util open Names open Term open Termops +open Namegen open Tacmach open Sign open Environ @@ -60,7 +63,7 @@ open Tactics open Tacticals open Printer -type term_with_holes = TH of constr * metamap * sg_proofs +type term_with_holes = TH of constr * meta_type_map * sg_proofs and sg_proofs = (term_with_holes option) list (* pour debugger *) @@ -70,12 +73,12 @@ let rec pp_th (TH(c,mm,sg)) = (* pp_mm mm ++ fnl () ++ *) pp_sg sg) ++ str "]") and pp_mm l = - hov 0 (prlist_with_sep (fun _ -> (fnl ())) + hov 0 (prlist_with_sep (fun _ -> (fnl ())) (fun (n,c) -> (int n ++ str" --> " ++ pr_lconstr c)) l) and pp_sg sg = hov 0 (prlist_with_sep (fun _ -> (fnl ())) (function None -> (str"None") | Some th -> (pp_th th)) sg) - + (* compute_metamap : constr -> 'a evar_map -> term_with_holes * réalise le 2. ci-dessus * @@ -84,7 +87,7 @@ and pp_sg sg = * par un terme de preuve incomplet (Some c). * * On a donc l'INVARIANT suivant : le terme c rendu est "de niveau 1" - * -- i.e. à plat -- et la meta_map contient autant d'éléments qu'il y + * -- i.e. à plat -- et la meta_map contient autant d'éléments qu'il y * a de meta-variables dans c. On suppose de plus que l'ordre dans la * meta_map correspond à celui des buts qui seront engendrés par le refine. *) @@ -101,11 +104,14 @@ let replace_by_meta env sigma = function | Lambda (Anonymous,c1,c2) when isCast c2 -> let _,_,t = destCast c2 in mkArrow c1 t | _ -> (* (App _ | Case _) -> *) - Retyping.get_type_of_with_meta env sigma mm c + let sigma' = + List.fold_right (fun (m,t) sigma -> Evd.meta_declare m t sigma) + mm sigma in + Retyping.get_type_of env sigma' c (* | Fix ((_,j),(v,_,_)) -> v.(j) (* en pleine confiance ! *) - | _ -> invalid_arg "Tcc.replace_by_meta (TO DO)" + | _ -> invalid_arg "Tcc.replace_by_meta (TO DO)" *) in if occur_meta ty then @@ -119,28 +125,28 @@ let replace_in_array keep_length env sigma a = raise NoMeta; let a' = Array.map (function | (TH (c,mm,[])) when not keep_length -> c,mm,[] - | th -> replace_by_meta env sigma th) a + | th -> replace_by_meta env sigma th) a in let v' = Array.map pi1 a' in let mm = Array.fold_left (@) [] (Array.map pi2 a') in let sgp = Array.fold_left (@) [] (Array.map pi3 a') in v',mm,sgp - + let fresh env n = let id = match n with Name x -> x | _ -> id_of_string "_H" in - next_global_ident_away true id (ids_of_named_context (named_context env)) + next_ident_away_in_goal id (ids_of_named_context (named_context env)) let rec compute_metamap env sigma c = match kind_of_term c with (* le terme est directement une preuve *) | (Const _ | Evar _ | Ind _ | Construct _ | - Sort _ | Var _ | Rel _) -> + Sort _ | Var _ | Rel _) -> TH (c,[],[]) (* le terme est une mv => un but *) | Meta n -> TH (c,[],[None]) - | Cast (m,_, ty) when isMeta m -> + | Cast (m,_, ty) when isMeta m -> TH (c,[destMeta m,ty],[None]) @@ -153,7 +159,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with begin match compute_metamap env' sigma (subst1 (mkVar v) c2) with (* terme de preuve complet *) | TH (_,_,[]) -> TH (c,[],[]) - (* terme de preuve incomplet *) + (* terme de preuve incomplet *) | th -> let m,mm,sgp = replace_by_meta env' sigma th in TH (mkLambda (Name v,c1,m), mm, sgp) @@ -167,13 +173,13 @@ let rec compute_metamap env sigma c = match kind_of_term c with begin match th1,th2 with (* terme de preuve complet *) | TH (_,_,[]), TH (_,_,[]) -> TH (c,[],[]) - (* terme de preuve incomplet *) + (* terme de preuve incomplet *) | TH (c1,mm1,sgp1), TH (c2,mm2,sgp2) -> let m1,mm1,sgp1 = - if sgp1=[] then (c1,mm1,[]) + if sgp1=[] then (c1,mm1,[]) else replace_by_meta env sigma th1 in let m2,mm2,sgp2 = - if sgp2=[] then (c2,mm2,[]) + if sgp2=[] then (c2,mm2,[]) else replace_by_meta env' sigma th2 in TH (mkNamedLetIn v m1 t1 m2, mm1@mm2, sgp1@sgp2) end @@ -214,7 +220,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with let env' = push_named_rec_types (fi',ai,v) env in let a = Array.map (compute_metamap env' sigma) - (Array.map (substl (List.map mkVar (Array.to_list vi))) v) + (Array.map (substl (List.map mkVar (Array.to_list vi))) v) in begin try @@ -224,12 +230,12 @@ let rec compute_metamap env sigma c = match kind_of_term c with with NoMeta -> TH (c,[],[]) end - + (* Cast. Est-ce bien exact ? *) | Cast (c,_,t) -> compute_metamap env sigma c (*let TH (c',mm,sgp) = compute_metamap sign c in TH (mkCast (c',t),mm,sgp) *) - + (* Produit. Est-ce bien exact ? *) | Prod (_,_,_) -> if occur_meta c then @@ -244,7 +250,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with let env' = push_named_rec_types (fi',ai,v) env in let a = Array.map (compute_metamap env' sigma) - (Array.map (substl (List.map mkVar (Array.to_list vi))) v) + (Array.map (substl (List.map mkVar (Array.to_list vi))) v) in begin try @@ -257,7 +263,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with (* tcc_aux : term_with_holes -> tactic - * + * * Réalise le 3. ci-dessus *) @@ -270,11 +276,11 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = | Cast (c,_,_), _ when isMeta c -> tclIDTAC gl - + (* terme pur => refine *) | _,[] -> refine c gl - + (* abstraction => intro *) | Lambda (Name id,_,m), _ -> assert (isMeta (strip_outer_cast m)); @@ -282,18 +288,18 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = | [None] -> intro_mustbe_force id gl | [Some th] -> tclTHEN (introduction id) - (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)) gl + (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)) gl | _ -> assert false end | Lambda (Anonymous,_,m), _ -> (* if anon vars are allowed in evars *) assert (isMeta (strip_outer_cast m)); begin match sgp with - | [None] -> tclTHEN intro (onLastHyp (fun id -> clear [id])) gl + | [None] -> tclTHEN intro (onLastHypId (fun id -> clear [id])) gl | [Some th] -> tclTHEN intro - (onLastHyp (fun id -> + (onLastHypId (fun id -> tclTHEN (clear [id]) (tcc_aux (mkVar (*dummy*) id::subst) th))) gl @@ -304,29 +310,29 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = | LetIn (Name id,c1,t1,c2), _ when not (isMeta (strip_outer_cast c1)) -> let c = pf_concl gl in let newc = mkNamedLetIn id c1 t1 c in - tclTHEN - (change_in_concl None newc) - (match sgp with + tclTHEN + (change_in_concl None newc) + (match sgp with | [None] -> introduction id | [Some th] -> tclTHEN (introduction id) - (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)) - | _ -> assert false) + (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)) + | _ -> assert false) gl (* let in with holes in the body => unable to handle dependency because of evars limitation, use non dependent assert instead *) | LetIn (Name id,c1,t1,c2), _ -> tclTHENS - (assert_tac (Name id) t1) - [(match List.hd sgp with + (assert_tac (Name id) t1) + [(match List.hd sgp with | None -> tclIDTAC - | Some th -> onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)); - (match List.tl sgp with + | Some th -> onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)); + (match List.tl sgp with | [] -> refine (subst1 (mkVar id) c2) (* a complete proof *) | [None] -> tclIDTAC (* a meta *) | [Some th] -> (* a partial proof *) - onLastHyp (fun id -> tcc_aux (mkVar id::subst) th) + onLastHypId (fun id -> tcc_aux (mkVar id::subst) th) | _ -> assert false)] gl @@ -339,10 +345,9 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = let fixes = array_map3 (fun f n c -> (out_name f,succ n,c)) fi ni ai in let firsts,lasts = list_chop j (Array.to_list fixes) in tclTHENS - (mutual_fix_with_index - (out_name fi.(j)) (succ ni.(j)) (firsts@List.tl lasts) j) + (mutual_fix (out_name fi.(j)) (succ ni.(j)) (firsts@List.tl lasts) j) (List.map (function - | None -> tclIDTAC + | None -> tclIDTAC | Some th -> tcc_aux subst th) sgp) gl @@ -355,9 +360,9 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = let cofixes = array_map2 (fun f c -> (out_name f,c)) fi ai in let firsts,lasts = list_chop j (Array.to_list cofixes) in tclTHENS - (mutual_cofix_with_index (out_name fi.(j)) (firsts@List.tl lasts) j) + (mutual_cofix (out_name fi.(j)) (firsts@List.tl lasts) j) (List.map (function - | None -> tclIDTAC + | None -> tclIDTAC | Some th -> tcc_aux subst th) sgp) gl @@ -374,13 +379,10 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = let refine (evd,c) gl = let sigma = project gl in - let evd = Evd.evars_of (Typeclasses.resolve_typeclasses - ~onlyargs:true ~fail:false (pf_env gl) - (Evd.create_evar_defs evd)) - in + let evd = Typeclasses.resolve_typeclasses ~onlyargs:true (pf_env gl) evd in let c = Evarutil.nf_evar evd c in let (evd,c) = Evarutil.evars_to_metas sigma (evd,c) in - (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise + (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise complicated to update meta types when passing through a binder *) let th = compute_metamap (pf_env gl) evd c in tclTHEN (Refiner.tclEVARS evd) (tcc_aux [] th) gl diff --git a/tactics/refine.mli b/tactics/refine.mli index aae1f5e1..89e53167 100644 --- a/tactics/refine.mli +++ b/tactics/refine.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: refine.mli 6099 2004-09-12 11:38:09Z barras $ i*) +(*i $Id$ i*) open Tacmach diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 new file mode 100644 index 00000000..3447f607 --- /dev/null +++ b/tactics/rewrite.ml4 @@ -0,0 +1,1542 @@ +(* -*- compile-command: "make -C .. bin/coqtop.byte" -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* $Id: rewrite.ml4 11981 2009-03-16 08:18:53Z herbelin $ *) + +open Pp +open Util +open Names +open Nameops +open Namegen +open Term +open Termops +open Sign +open Reduction +open Proof_type +open Proof_trees +open Declarations +open Tacticals +open Tacmach +open Evar_refiner +open Tactics +open Pattern +open Clenv +open Auto +open Rawterm +open Hiddentac +open Typeclasses +open Typeclasses_errors +open Classes +open Topconstr +open Pfedit +open Command +open Libnames +open Evd + +(** Typeclass-based generalized rewriting. *) + +let check_required_library d = + let d' = List.map id_of_string d in + let dir = make_dirpath (List.rev d') in + if not (Library.library_is_loaded dir) then + error ("Library "^(list_last d)^" has to be required first.") + +let classes_dirpath = + make_dirpath (List.map id_of_string ["Classes";"Coq"]) + +let init_setoid () = + if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () + else check_required_library ["Coq";"Setoids";"Setoid"] + +let proper_class = + lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Proper")))) + +let proper_proxy_class = + lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.ProperProxy")))) + +let proper_proj = lazy (mkConst (Option.get (snd (List.hd (Lazy.force proper_class).cl_projs)))) + +let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) + +let try_find_global_reference dir s = + let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in + Nametab.global_of_path sp + +let try_find_reference dir s = + constr_of_global (try_find_global_reference dir s) + +let gen_constant dir s = Coqlib.gen_constant "rewrite" dir s +let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1") +let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2") +let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq") +let coq_eq_rect = lazy (gen_constant ["Init"; "Logic"] "eq_rect") +let coq_f_equal = lazy (gen_constant ["Init"; "Logic"] "f_equal") +let iff = lazy (gen_constant ["Init"; "Logic"] "iff") +let coq_all = lazy (gen_constant ["Init"; "Logic"] "all") +let impl = lazy (gen_constant ["Program"; "Basics"] "impl") +let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow") +let coq_id = lazy (gen_constant ["Init"; "Datatypes"] "id") + +let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive") +let reflexive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "reflexivity") +let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity") + +let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric") +let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry") +let symmetric_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "symmetry") + +let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive") +let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity") +let transitive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "transitivity") + +let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse" *) + ["Program"; "Basics"] "flip") + +let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) +(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; new_Type (); rel |]) *) + +let complement = lazy (gen_constant ["Classes"; "RelationClasses"] "complement") +let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") +let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") + +let respectful_dep = lazy (gen_constant ["Classes"; "Morphisms"] "respectful_dep") +let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") + +let equivalence = lazy (gen_constant ["Classes"; "RelationClasses"] "Equivalence") +let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") + +let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") +let is_subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "is_subrelation") +let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") +let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") + +let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") +let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) +(* let mk_relation a = mkProd (Anonymous, a, mkProd (Anonymous, a, new_Type ())) *) + +let coq_relationT = lazy (gen_constant ["Classes";"Relations"] "relationT") + +let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive") + +let setoid_equiv = lazy (gen_constant ["Classes"; "SetoidClass"] "equiv") +let setoid_proper = lazy (gen_constant ["Classes"; "SetoidClass"] "setoid_proper") +let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive") + +let rewrite_relation_class = lazy (gen_constant ["Classes"; "RelationClasses"] "RewriteRelation") +let rewrite_relation = lazy (gen_constant ["Classes"; "RelationClasses"] "rewrite_relation") + +let arrow_morphism a b = + if isprop a && isprop b then + Lazy.force impl + else + mkApp(Lazy.force arrow, [|a;b|]) + +let setoid_refl pars x = + applistc (Lazy.force setoid_refl_proj) (pars @ [x]) + +let proper_type = lazy (constr_of_global (Lazy.force proper_class).cl_impl) + +let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).cl_impl) + +let is_applied_rewrite_relation env sigma rels t = + match kind_of_term t with + | App (c, args) when Array.length args >= 2 -> + let head = if isApp c then fst (destApp c) else c in + if eq_constr (Lazy.force coq_eq) head then None + else + (try + let params, args = array_chop (Array.length args - 2) args in + let env' = Environ.push_rel_context rels env in + let evd, evar = Evarutil.new_evar sigma env' (new_Type ()) in + let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in + let _ = Typeclasses.resolve_one_typeclass env' evd inst in + Some (it_mkProd_or_LetIn t rels) + with _ -> None) + | _ -> None + +let _ = + Equality.register_is_applied_rewrite_relation is_applied_rewrite_relation + +let split_head = function + hd :: tl -> hd, tl + | [] -> assert(false) + +let new_goal_evar (goal,cstr) env t = + let goal', t = Evarutil.new_evar goal env t in + (goal', cstr), t + +let new_cstr_evar (goal,cstr) env t = + let cstr', t = Evarutil.new_evar cstr env t in + (goal, cstr'), t + +let build_signature evars env m (cstrs : 'a option list) (finalcstr : 'a option) (f : 'a -> constr) = + let new_evar evars env t = + new_cstr_evar evars env + (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t + in + let mk_relty evars env ty obj = + match obj with + | None -> + let relty = mk_relation ty in + new_evar evars env relty + | Some x -> evars, f x + in + let rec aux env evars ty l = + let t = Reductionops.whd_betadeltaiota env (fst evars) ty in + match kind_of_term t, l with + | Prod (na, ty, b), obj :: cstrs -> + if noccurn 1 b (* non-dependent product *) then + let ty = Reductionops.nf_betaiota (fst evars) ty in + let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in + let evars, relty = mk_relty evars env ty obj in + let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in + evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs + else + let (evars, b, arg, cstrs) = aux (Environ.push_rel (na, None, ty) env) evars b cstrs in + let ty = Reductionops.nf_betaiota (fst evars) ty in + let pred = mkLambda (na, ty, b) in + let liftarg = mkLambda (na, ty, arg) in + let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in + if obj = None then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs + else error "build_signature: no constraint can apply on a dependent argument" + | _, obj :: _ -> anomaly "build_signature: not enough products" + | _, [] -> + (match finalcstr with + | None -> + let t = Reductionops.nf_betaiota (fst evars) ty in + let evars, rel = mk_relty evars env t None in + evars, t, rel, [t, Some rel] + | Some codom -> let (t, rel) = codom in + evars, t, rel, [t, Some rel]) + in aux env evars m cstrs + +let proper_proof env evars carrier relation x = + let goal = mkApp (Lazy.force proper_proxy_type, [| carrier ; relation; x |]) + in new_cstr_evar evars env goal + +let find_class_proof proof_type proof_method env evars carrier relation = + try + let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in + let evars, c = Typeclasses.resolve_one_typeclass env evars goal in + mkApp (Lazy.force proof_method, [| carrier; relation; c |]) + with e when Logic.catchable_exception e -> raise Not_found + +let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env +let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env +let get_transitive_proof env = find_class_proof transitive_type transitive_proof env + +exception FoundInt of int + +let array_find (arr: 'a array) (pred: int -> 'a -> bool): int = + try + for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (FoundInt i) done; + raise Not_found + with FoundInt i -> i + +type hypinfo = { + cl : clausenv; + prf : constr; + car : constr; + rel : constr; + l2r : bool; + c1 : constr; + c2 : constr; + c : constr option; + abs : (constr * types) option; +} + +let evd_convertible env evd x y = + try ignore(Evarconv.the_conv_x env x y evd); true + with _ -> false + +let decompose_applied_relation env sigma c left2right = + let ctype = Typing.type_of env sigma c in + let find_rel ty = + let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) 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 + let ty1, ty2 = + Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2 + in + if not (evd_convertible env eqclause.evd ty1 ty2) then None + else + Some { cl=eqclause; prf=(Clenv.clenv_value eqclause); + car=ty1; rel=mkApp (equiv, Array.of_list others); + l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None } + in + match find_rel ctype with + | Some c -> c + | None -> + let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' ctx) with + | Some c -> c + | None -> error "The term does not end with an applied homogeneous relation." + +let rewrite_unif_flags = { + Unification.modulo_conv_on_closed_terms = None; + Unification.use_metas_eagerly = true; + Unification.modulo_delta = empty_transparent_state; + Unification.resolve_evars = true; + Unification.use_evars_pattern_unification = true; +} + +let conv_transparent_state = (Idpred.empty, Cpred.full) + +let rewrite2_unif_flags = { + Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; + Unification.use_metas_eagerly = true; + Unification.modulo_delta = empty_transparent_state; + Unification.resolve_evars = true; + Unification.use_evars_pattern_unification = true; +} + +let setoid_rewrite_unif_flags = { + Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; + Unification.use_metas_eagerly = true; + Unification.modulo_delta = conv_transparent_state; + Unification.resolve_evars = true; + Unification.use_evars_pattern_unification = true; +} + +let convertible env evd x y = + Reductionops.is_conv env evd x y + +let allowK = true + +let refresh_hypinfo env sigma hypinfo = + if hypinfo.abs = None then + let {l2r=l2r; c=c;cl=cl} = hypinfo in + match c with + | Some c -> + (* Refresh the clausenv to not get the same meta twice in the goal. *) + decompose_applied_relation env cl.evd c l2r; + | _ -> hypinfo + else hypinfo + +let unify_eqn env sigma hypinfo t = + if isEvar t then None + else try + let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in + let left = if l2r then c1 else c2 in + let env', prf, c1, c2, car, rel = + match abs with + | Some (absprf, absprfty) -> + let env' = clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl in + env', prf, c1, c2, car, rel + | None -> + let env' = + try clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl + with Pretype_errors.PretypeError _ -> + (* For Ring essentially, only when doing setoid_rewrite *) + clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl + in + let env' = + let mvs = clenv_dependent false env' in + clenv_pose_metas_as_evars env' mvs + in + let evd' = Typeclasses.resolve_typeclasses ~fail:true env'.env env'.evd in + let env' = { env' with evd = evd' } in + let nf c = Evarutil.nf_evar evd' (Clenv.clenv_nf_meta env' c) in + let c1 = nf c1 and c2 = nf c2 + and car = nf car and rel = nf rel + and prf = nf (Clenv.clenv_value env') in + let ty1 = Typing.type_of env'.env env'.evd c1 + and ty2 = Typing.type_of env'.env env'.evd c2 + in + if convertible env env'.evd ty1 ty2 then ( + if occur_meta prf then + hypinfo := refresh_hypinfo env sigma !hypinfo; + env', prf, c1, c2, car, rel) + else raise Reduction.NotConvertible + in + let res = + if l2r then (prf, (car, rel, c1, c2)) + else + try (mkApp (get_symmetric_proof env Evd.empty car rel, + [| c1 ; c2 ; prf |]), + (car, rel, c2, c1)) + with Not_found -> + (prf, (car, inverse car rel, c2, c1)) + in Some (env', res) + with e when Class_tactics.catchable e -> None + +let unfold_impl t = + match kind_of_term t with + | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> + mkProd (Anonymous, a, lift 1 b) + | _ -> assert false + +let unfold_id t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_id) *) -> b + | _ -> assert false + +let unfold_all t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + +let decomp_prod env evm n c = + snd (Reductionops.splay_prod_n env evm n c) + +let rec decomp_pointwise n c = + if n = 0 then c + else + match kind_of_term c with + | App (pointwise, [| a; b; relb |]) -> decomp_pointwise (pred n) relb + | _ -> raise Not_found + +let lift_cstr env sigma evars args cstr = + let cstr = + let start = + match cstr with + | Some codom -> codom + | None -> + let car = Evarutil.e_new_evar evars env (new_Type ()) in + let rel = Evarutil.e_new_evar evars env (mk_relation car) in + (car, rel) + in + Array.fold_right + (fun arg (car, rel) -> + let ty = Typing.type_of env sigma arg in + let car' = mkProd (Anonymous, ty, car) in + let rel' = mkApp (Lazy.force pointwise_relation, [| ty; car; rel |]) in + (car', rel')) + args start + in Some cstr + +let unlift_cstr env sigma = function + | None -> None + | Some codom -> Some (decomp_pointwise 1 codom) + +type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } + +let default_flags = { under_lambdas = true; on_morphisms = true; } + +type evars = evar_map * evar_map (* goal evars, constraint evars *) + +type rewrite_result_info = { + rew_car : constr; + rew_rel : constr; + rew_from : constr; + rew_to : constr; + rew_prf : constr; + rew_evars : evars; +} + +type rewrite_result = rewrite_result_info option + +type strategy = Environ.env -> evar_map -> constr -> types -> + constr option -> evars -> rewrite_result option + +let resolve_subrelation env sigma car rel rel' res = + if eq_constr rel rel' then res + else +(* try let evd' = Evarconv.the_conv_x env rel rel' res.rew_evars in *) +(* { res with rew_evars = evd' } *) +(* with NotConvertible -> *) + let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in + let evars, subrel = new_cstr_evar res.rew_evars env app in + { res with + rew_prf = mkApp (subrel, [| res.rew_from ; res.rew_to ; res.rew_prf |]); + rew_rel = rel'; + rew_evars = evars } + + +let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars = + let evars, morph_instance, proj, sigargs, m', args, args' = + let first = try (array_find args' (fun i b -> b <> None)) + with Not_found -> raise (Invalid_argument "resolve_morphism") in + let morphargs, morphobjs = array_chop first args in + let morphargs', morphobjs' = array_chop first args' in + let appm = mkApp(m, morphargs) in + let appmtype = Typing.type_of env sigma appm in + let cstrs = List.map (Option.map (fun r -> r.rew_car, r.rew_rel)) (Array.to_list morphobjs') in + (* Desired signature *) + let evars, appmtype', signature, sigargs = build_signature evars env appmtype cstrs cstr (fun (a,r) -> r) in + (* Actual signature found *) + let cl_args = [| appmtype' ; signature ; appm |] in + let app = mkApp (Lazy.force proper_type, cl_args) in + let env' = Environ.push_named + (id_of_string "do_subrelation", Some (Lazy.force do_subrelation), Lazy.force apply_subrelation) + env + in + let evars, morph = new_cstr_evar evars env' app in + evars, morph, morph, sigargs, appm, morphobjs, morphobjs' + in + let projargs, subst, evars, respars, typeargs = + array_fold_left2 + (fun (acc, subst, evars, sigargs, typeargs') x y -> + let (carrier, relation), sigargs = split_head sigargs in + match relation with + | Some relation -> + let carrier = substl subst carrier + and relation = substl subst relation in + (match y with + | None -> + let evars, proof = proper_proof env evars carrier relation x in + [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' + | Some r -> + [ r.rew_prf; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') + | None -> + if y <> None then error "Cannot rewrite the argument of a dependent function"; + x :: acc, x :: subst, evars, sigargs, x :: typeargs') + ([], [], evars, sigargs, []) args args' + in + let proof = applistc proj (List.rev projargs) in + let newt = applistc m' (List.rev typeargs) in + match respars with + [ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt + | _ -> assert(false) + +let apply_constraint env sigma car rel cstr res = + match cstr with + | None -> res + | Some r -> resolve_subrelation env sigma car rel r res + +let eq_env x y = x == y + +let apply_rule hypinfo loccs : strategy = + let (nowhere_except_in,occs) = loccs in + let is_occ occ = + if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in + let occ = ref 0 in + fun env sigma t ty cstr evars -> + if not (eq_env !hypinfo.cl.env env) then hypinfo := refresh_hypinfo env sigma !hypinfo; + let unif = unify_eqn env sigma hypinfo t in + if unif <> None then incr occ; + match unif with + | Some (env', (prf, (car, rel, c1, c2))) when is_occ !occ -> + begin + let goalevars = Evd.evar_merge (fst evars) + (Evd.undefined_evars (Evarutil.nf_evar_map env'.evd)) + in + let res = { rew_car = ty; rew_rel = rel; rew_from = c1; + rew_to = c2; rew_prf = prf; rew_evars = goalevars, snd evars } + in Some (Some (apply_constraint env sigma car rel cstr res)) + end + | _ -> None + +let apply_lemma (evm,c) left2right loccs : strategy = + fun env sigma -> + let evars = Evd.merge sigma evm in + let hypinfo = ref (decompose_applied_relation env evars c left2right) in + apply_rule hypinfo loccs env sigma + +let make_leibniz_proof c ty r = + let prf = mkApp (Lazy.force coq_f_equal, + [| r.rew_car; ty; + mkLambda (Anonymous, r.rew_car, c (mkRel 1)); + r.rew_from; r.rew_to; r.rew_prf |]) + in + { r with rew_car = ty; rew_rel = mkApp (Lazy.force coq_eq, [| ty |]); + rew_from = c r.rew_from; rew_to = c r.rew_to; rew_prf = prf } + +let pointwise_or_dep_relation n t car rel = + if noccurn 1 car then + mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |]) + else + mkApp (Lazy.force forall_relation, + [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]) + +let subterm all flags (s : strategy) : strategy = + let rec aux env sigma t ty cstr evars = + let cstr' = Option.map (fun c -> (ty, c)) cstr in + match kind_of_term t with + | App (m, args) -> + let rewrite_args success = + let args', evars', progress = + Array.fold_left + (fun (acc, evars, progress) arg -> + if progress <> None && not all then (None :: acc, evars, progress) + else + let res = s env sigma arg (Typing.type_of env sigma arg) None evars in + match res with + | Some None -> (None :: acc, evars, if progress = None then Some false else progress) + | Some (Some r) -> (Some r :: acc, r.rew_evars, Some true) + | None -> (None :: acc, evars, progress)) + ([], evars, success) args + in + match progress with + | None -> None + | Some false -> Some None + | Some true -> + let args' = Array.of_list (List.rev args') in + let evars', prf, car, rel, c1, c2 = resolve_morphism env sigma t m args args' cstr' evars' in + let res = { rew_car = ty; rew_rel = rel; rew_from = c1; + rew_to = c2; rew_prf = prf; rew_evars = evars' } in + Some (Some res) + in + if flags.on_morphisms then + let evarsref = ref (snd evars) in + let cstr' = lift_cstr env sigma evarsref args cstr' in + let m' = s env sigma m (Typing.type_of env sigma m) + (Option.map snd cstr') (fst evars, !evarsref) + in + match m' with + | None -> rewrite_args None (* Standard path, try rewrite on arguments *) + | Some None -> rewrite_args (Some false) + | Some (Some r) -> + (* We rewrote the function and get a proof of pointwise rel for the arguments. + We just apply it. *) + let nargs = Array.length args in + let res = + { rew_car = decomp_prod env (fst r.rew_evars) nargs r.rew_car; + rew_rel = decomp_pointwise nargs r.rew_rel; + rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); + rew_prf = mkApp (r.rew_prf, args); rew_evars = r.rew_evars } + in Some (Some res) + else rewrite_args None + + | Prod (n, x, b) when noccurn 1 b -> + let b = subst1 mkProp b in + let tx = Typing.type_of env sigma x and tb = Typing.type_of env sigma b in + let res = aux env sigma (mkApp (arrow_morphism tx tb, [| x; b |])) ty cstr evars in + (match res with + | Some (Some r) -> Some (Some { r with rew_to = unfold_impl r.rew_to }) + | _ -> res) + + (* if x' = None && flags.under_lambdas then *) + (* let lam = mkLambda (n, x, b) in *) + (* let lam', occ = aux env lam occ None in *) + (* let res = *) + (* match lam' with *) + (* | None -> None *) + (* | Some (prf, (car, rel, c1, c2)) -> *) + (* Some (resolve_morphism env sigma t *) + (* ~fnewt:unfold_all *) + (* (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *) + (* cstr evars) *) + (* in res, occ *) + (* else *) + + | Prod (n, dom, codom) when eq_constr ty mkProp -> + let lam = mkLambda (n, dom, codom) in + let res = aux env sigma (mkApp (Lazy.force coq_all, [| dom; lam |])) ty cstr evars in + (match res with + | Some (Some r) -> Some (Some { r with rew_to = unfold_all r.rew_to }) + | _ -> res) + + | Lambda (n, t, b) when flags.under_lambdas -> + let env' = Environ.push_rel (n, None, t) env in + let b' = s env' sigma b (Typing.type_of env' sigma b) (unlift_cstr env sigma cstr) evars in + (match b' with + | Some (Some r) -> + Some (Some { r with + rew_prf = mkLambda (n, t, r.rew_prf); + rew_car = mkProd (n, t, r.rew_car); + rew_rel = pointwise_or_dep_relation n t r.rew_car r.rew_rel; + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) }) + | _ -> b') + + | Case (ci, p, c, brs) -> + let cty = Typing.type_of env sigma c in + let cstr = Some (mkApp (Lazy.force coq_eq, [| cty |])) in + let c' = s env sigma c cty cstr evars in + (match c' with + | Some (Some r) -> + Some (Some (make_leibniz_proof (fun x -> mkCase (ci, p, x, brs)) ty r)) + | x -> + if array_for_all ((=) 0) ci.ci_cstr_nargs then + let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in + let found, brs' = Array.fold_left (fun (found, acc) br -> + if found <> None then (found, fun x -> br :: acc x) + else + match s env sigma br ty cstr evars with + | Some (Some r) -> (Some r, fun x -> x :: acc x) + | _ -> (None, fun x -> br :: acc x)) + (None, fun x -> []) brs + in + match found with + | Some r -> + let ctxc x = mkCase (ci, p, c, Array.of_list (List.rev (brs' x))) in + Some (Some (make_leibniz_proof ctxc ty r)) + | None -> x + else x) + + | _ -> if all then Some None else None + in aux + +let all_subterms = subterm true default_flags +let one_subterm = subterm false default_flags + +(** Requires transitivity of the rewrite step, not tail-recursive. *) + +let transitivity env sigma (res : rewrite_result_info) (next : strategy) : rewrite_result option = + match next env sigma res.rew_to res.rew_car (Some res.rew_rel) res.rew_evars with + | None -> None + | Some None -> Some (Some res) + | Some (Some res') -> + let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car ; res.rew_rel |]) in + let evars, prf = new_cstr_evar res'.rew_evars env prfty in + let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; + res.rew_prf; res'.rew_prf |]) + in Some (Some { res' with rew_from = res.rew_from; rew_evars = evars; rew_prf = prf }) + +(** Rewriting strategies. + + Inspired by ELAN's rewriting strategies: + http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049 +*) + +module Strategies = + struct + + let fail : strategy = + fun env sigma t ty cstr evars -> None + + let id : strategy = + fun env sigma t ty cstr evars -> Some None + + let refl : strategy = + fun env sigma t ty cstr evars -> + let evars, rel = match cstr with + | None -> new_cstr_evar evars env (mk_relation ty) + | Some r -> evars, r + in + let evars, proof = + let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in + new_cstr_evar evars env mty + in + Some (Some { rew_car = ty; rew_rel = rel; rew_from = t; rew_to = t; + rew_prf = proof; rew_evars = evars }) + + let progress (s : strategy) : strategy = + fun env sigma t ty cstr evars -> + match s env sigma t ty cstr evars with + | None -> None + | Some None -> None + | r -> r + + let seq fst snd : strategy = + fun env sigma t ty cstr evars -> + match fst env sigma t ty cstr evars with + | None -> None + | Some None -> snd env sigma t ty cstr evars + | Some (Some res) -> transitivity env sigma res snd + + let choice fst snd : strategy = + fun env sigma t ty cstr evars -> + match fst env sigma t ty cstr evars with + | None -> snd env sigma t ty cstr evars + | res -> res + + let try_ str : strategy = choice str id + + let fix (f : strategy -> strategy) : strategy = + let rec aux env = f (fun env -> aux env) env in aux + + let any (s : strategy) : strategy = + fix (fun any -> try_ (seq s any)) + + let repeat (s : strategy) : strategy = + seq s (any s) + + let bu (s : strategy) : strategy = + fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) + + let td (s : strategy) : strategy = + fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) + + let innermost (s : strategy) : strategy = + fix (fun ins -> choice (one_subterm ins) s) + + let outermost (s : strategy) : strategy = + fix (fun out -> choice s (one_subterm out)) + + let lemmas cs : strategy = + List.fold_left (fun tac (l,l2r) -> + choice tac (apply_lemma l l2r (false,[]))) + fail cs + + let inj_open c = (Evd.empty,c) + + let old_hints (db : string) : strategy = + let rules = Autorewrite.find_rewrites db in + lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules) + + let hints (db : string) : strategy = + fun env sigma t ty cstr evars -> + let rules = Autorewrite.find_matches db t in + lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules) + env sigma t ty cstr evars + +end + +(** The strategy for a single rewrite, dealing with occurences. *) + +let rewrite_strat flags occs hyp = + let app = apply_rule hyp occs in + let rec aux () = + Strategies.choice app (subterm true flags (fun env -> aux () env)) + in aux () + +let rewrite_with (evm,c) left2right loccs : strategy = + fun env sigma -> + let evars = Evd.merge sigma evm in + let hypinfo = ref (decompose_applied_relation env evars c left2right) in + rewrite_strat default_flags loccs hypinfo env sigma + +let apply_strategy (s : strategy) env sigma concl cstr evars = + let res = + s env sigma concl (Typing.type_of env sigma concl) + (Option.map snd cstr) !evars + in + match res with + | None -> None + | Some None -> Some None + | Some (Some res) -> + evars := res.rew_evars; + Some (Some (res.rew_prf, (res.rew_car, res.rew_rel, res.rew_from, res.rew_to))) + +let split_evars_once sigma evd = + Evd.fold (fun ev evi deps -> + if Intset.mem ev deps then + Intset.union (Class_tactics.evars_of_evi evi) deps + else deps) evd sigma + +let existentials_of_evd evd = + Evd.fold (fun ev evi acc -> Intset.add ev acc) evd Intset.empty + +let evd_of_existentials evd exs = + Intset.fold (fun i acc -> + let evi = Evd.find evd i in + Evd.add acc i evi) exs Evd.empty + +let split_evars sigma evd = + let rec aux deps = + let deps' = split_evars_once deps evd in + if Intset.equal deps' deps then + evd_of_existentials evd deps + else aux deps' + in aux (existentials_of_evd sigma) + +let merge_evars (goal,cstr) = Evd.merge goal cstr +let solve_constraints env evars = + Typeclasses.resolve_typeclasses env ~split:false ~fail:true (merge_evars evars) + +let nf_zeta = + Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + +let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = + let concl, is_hyp = + match clause with + Some id -> pf_get_hyp_typ gl id, Some id + | None -> pf_concl gl, None + in + let cstr = + let sort = mkProp in + let impl = Lazy.force impl in + match is_hyp with + | None -> (sort, inverse sort impl) + | Some _ -> (sort, impl) + in + let sigma = project gl in + let evars = ref (Evd.create_evar_defs sigma, Evd.empty) in + let env = pf_env gl in + let eq = apply_strategy strat env sigma concl (Some cstr) evars in + match eq with + | Some (Some (p, (_, _, oldt, newt))) -> + (try + let cstrevars = !evars in + let evars = solve_constraints env cstrevars in + let p = Evarutil.nf_evar evars p in + let p = nf_zeta env evars p in + let newt = Evarutil.nf_evar evars newt in + let abs = Option.map (fun (x, y) -> + Evarutil.nf_evar evars x, Evarutil.nf_evar evars y) abs in + let undef = split_evars (fst cstrevars) evars in + let rewtac = + match is_hyp with + | Some id -> + let term = + match abs with + | None -> p + | Some (t, ty) -> + mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) + in + cut_replacing id newt + (Tacmach.refine_no_check (mkApp (term, [| mkVar id |]))) + | None -> + (match abs with + | None -> + let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in + tclTHENLAST + (Tacmach.internal_cut_no_check false name newt) + (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p)) + | Some (t, ty) -> + Tacmach.refine_no_check + (mkApp (mkLambda (Name (id_of_string "newt"), newt, + mkLambda (Name (id_of_string "lemma"), ty, + mkApp (p, [| mkRel 2 |]))), + [| mkMeta goal_meta; t |]))) + in + let evartac = + if not (undef = Evd.empty) then + Refiner.tclEVARS undef + else tclIDTAC + in tclTHENLIST [evartac; rewtac] gl + with + | Stdpp.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e))) + | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> + Refiner.tclFAIL_lazy 0 + (lazy (str"setoid rewrite failed: unable to satisfy the rewriting constraints." + ++ fnl () ++ Himsg.explain_typeclass_error env e)) gl) + | Some None -> + tclFAIL 0 (str"setoid rewrite failed: no progress made") gl + | None -> raise Not_found + +let cl_rewrite_clause_strat strat clause gl = + init_setoid (); + let meta = Evarutil.new_meta() in + let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in + try cl_rewrite_clause_aux strat meta clause gl + with Not_found -> + tclFAIL 0 (str"setoid rewrite failed: strategy failed") gl + +let cl_rewrite_clause l left2right occs clause gl = + cl_rewrite_clause_strat (rewrite_with l left2right occs) clause gl + +open Pp +open Pcoq +open Names +open Tacexpr +open Tacinterp +open Termops +open Genarg +open Extraargs + +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) + +let pr_gen_strategy pr_id = Pp.mt () +let pr_loc_strategy _ _ _ = Pp.mt () +let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" + +let intern_strategy ist gl c = c +let interp_strategy ist gl c = c +let glob_strategy ist l = l +let subst_strategy evm l = l + +let apply_constr_expr c l2r occs = fun env sigma -> + let c = Constrintern.interp_open_constr sigma env c in + apply_lemma c l2r occs env sigma + +let interp_constr_list env sigma cs = + List.map (fun c -> Constrintern.interp_open_constr sigma env c, true) cs + +open Pcoq + +let (wit_strategy, globwit_strategy, rawwit_strategy) = + (Genarg.create_arg "strategy" : + ((strategy, Genarg.tlevel) Genarg.abstract_argument_type * + (strategy, Genarg.glevel) Genarg.abstract_argument_type * + (strategy, Genarg.rlevel) Genarg.abstract_argument_type)) + + +ARGUMENT EXTEND rewstrategy TYPED AS strategy + PRINTED BY pr_strategy + INTERPRETED BY interp_strategy + GLOBALIZED BY glob_strategy + SUBSTITUTED BY subst_strategy + + [ constr(c) ] -> [ apply_constr_expr c true all_occurrences ] + | [ "<-" constr(c) ] -> [ apply_constr_expr c false all_occurrences ] + | [ "subterms" rewstrategy(h) ] -> [ all_subterms h ] + | [ "subterm" rewstrategy(h) ] -> [ one_subterm h ] + | [ "innermost" rewstrategy(h) ] -> [ Strategies.innermost h ] + | [ "outermost" rewstrategy(h) ] -> [ Strategies.outermost h ] + | [ "bottomup" rewstrategy(h) ] -> [ Strategies.bu h ] + | [ "topdown" rewstrategy(h) ] -> [ Strategies.td h ] + | [ "id" ] -> [ Strategies.id ] + | [ "refl" ] -> [ Strategies.refl ] + | [ "progress" rewstrategy(h) ] -> [ Strategies.progress h ] + | [ "fail" ] -> [ Strategies.fail ] + | [ "try" rewstrategy(h) ] -> [ Strategies.try_ h ] + | [ "any" rewstrategy(h) ] -> [ Strategies.any h ] + | [ "repeat" rewstrategy(h) ] -> [ Strategies.repeat h ] + | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ Strategies.seq h h' ] + | [ "(" rewstrategy(h) ")" ] -> [ h ] + | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ Strategies.choice h h' ] + | [ "old_hints" preident(h) ] -> [ Strategies.old_hints h ] + | [ "hints" preident(h) ] -> [ Strategies.hints h ] + | [ "terms" constr_list(h) ] -> [ fun env sigma -> Strategies.lemmas (interp_constr_list env sigma h) env sigma ] +END + +TACTIC EXTEND class_rewrite +| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] +| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] +| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id) ] +| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ] +| [ "clrewrite" orient(o) open_constr(c) ] -> [ cl_rewrite_clause c o all_occurrences None ] + END + +TACTIC EXTEND class_rewrite_strat +| [ "clrewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] +(* | [ "clrewrite_strat" strategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] *) +END + + +let clsubstitute o c = + let is_tac id = match kind_of_term (snd c) with Var id' when id' = id -> true | _ -> false in + Tacticals.onAllHypsAndConcl + (fun cl -> + match cl with + | Some id when is_tac id -> tclIDTAC + | _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl)) + +TACTIC EXTEND substitute +| [ "substitute" orient(o) open_constr(c) ] -> [ clsubstitute o c ] +END + + +(* Compatibility with old Setoids *) + +TACTIC EXTEND setoid_rewrite + [ "setoid_rewrite" orient(o) open_constr(c) ] + -> [ cl_rewrite_clause c o all_occurrences None ] + | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) ] -> + [ cl_rewrite_clause c o all_occurrences (Some id)] + | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) ] -> + [ cl_rewrite_clause c o (occurrences_of occ) None] + | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id)] -> + [ cl_rewrite_clause c o (occurrences_of occ) (Some id)] + | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ)] -> + [ cl_rewrite_clause c o (occurrences_of occ) (Some id)] +END + +(* let solve_obligation lemma = *) +(* tclTHEN (Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor None))) *) +(* (eapply_with_bindings (Constrintern.interp_constr Evd.empty (Global.env()) lemma, NoBindings)) *) + +let mkappc s l = CAppExpl (dummy_loc,(None,(Libnames.Ident (dummy_loc,id_of_string s))),l) + +let declare_an_instance n s args = + ((dummy_loc,Name n), Explicit, + CAppExpl (dummy_loc, (None, Qualid (dummy_loc, qualid_of_string s)), + args)) + +let declare_instance a aeq n s = declare_an_instance n s [a;aeq] + +let anew_instance binders instance fields = + new_instance binders instance (CRecord (dummy_loc,None,fields)) ~generalize:false None + +let require_library dirpath = + let qualid = (dummy_loc, Libnames.qualid_of_dirpath (Libnames.dirpath_of_string dirpath)) in + Library.require_library [qualid] (Some false) + +let declare_instance_refl binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" + in anew_instance binders instance + [(Ident (dummy_loc,id_of_string "reflexivity"),lemma)] + +let declare_instance_sym binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" + in anew_instance binders instance + [(Ident (dummy_loc,id_of_string "symmetry"),lemma)] + +let declare_instance_trans binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" + in anew_instance binders instance + [(Ident (dummy_loc,id_of_string "transitivity"),lemma)] + +let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None))) + +let declare_relation ?(binders=[]) a aeq n refl symm trans = + init_setoid (); + let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" + in ignore(anew_instance binders instance []); + match (refl,symm,trans) with + (None, None, None) -> () + | (Some lemma1, None, None) -> + ignore (declare_instance_refl binders a aeq n lemma1) + | (None, Some lemma2, None) -> + ignore (declare_instance_sym binders a aeq n lemma2) + | (None, None, Some lemma3) -> + ignore (declare_instance_trans binders a aeq n lemma3) + | (Some lemma1, Some lemma2, None) -> + ignore (declare_instance_refl binders a aeq n lemma1); + ignore (declare_instance_sym binders a aeq n lemma2) + | (Some lemma1, None, Some lemma3) -> + let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in + let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" + in ignore( + anew_instance binders instance + [(Ident (dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1); + (Ident (dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)]) + | (None, Some lemma2, Some lemma3) -> + let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" + in ignore( + anew_instance binders instance + [(Ident (dummy_loc,id_of_string "PER_Symmetric"), lemma2); + (Ident (dummy_loc,id_of_string "PER_Transitive"),lemma3)]) + | (Some lemma1, Some lemma2, Some lemma3) -> + let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in + let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" + in ignore( + anew_instance binders instance + [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1); + (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2); + (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)]) + +type 'a binders_let_argtype = (local_binder list, 'a) Genarg.abstract_argument_type + +let (wit_binders_let : Genarg.tlevel binders_let_argtype), + (globwit_binders_let : Genarg.glevel binders_let_argtype), + (rawwit_binders_let : Genarg.rlevel binders_let_argtype) = + Genarg.create_arg "binders_let" + +open Pcoq.Constr + +VERNAC COMMAND EXTEND AddRelation + | [ "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 + [ "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 + [ "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 + +VERNAC COMMAND EXTEND AddParametricRelation + | [ "Add" "Parametric" "Relation" binders_let(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_let(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_let(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None None None ] +END + +VERNAC COMMAND EXTEND AddParametricRelation2 + [ "Add" "Parametric" "Relation" binders_let(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_let(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 + [ "Add" "Parametric" "Relation" binders_let(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_let(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_let(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 + +let mk_qualid s = + Libnames.Qualid (dummy_loc, Libnames.qualid_of_string s) + +let cHole = CHole (dummy_loc, None) + +open Entries +open Libnames + +let proper_projection r ty = + let ctx, inst = decompose_prod_assum ty in + let mor, args = destApp inst in + let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in + let app = mkApp (Lazy.force proper_proj, + Array.append args [| instarg |]) in + it_mkLambda_or_LetIn app ctx + +let declare_projection n instance_id r = + let ty = Global.type_of_global r in + let c = constr_of_global r in + let term = proper_projection c ty in + let typ = Typing.type_of (Global.env ()) Evd.empty term in + let ctx, typ = decompose_prod_assum typ in + let typ = + let n = + let rec aux t = + match kind_of_term t with + App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) -> + succ (aux rel') + | _ -> 0 + in + let init = + match kind_of_term typ with + App (f, args) when eq_constr f (Lazy.force respectful) -> + mkApp (f, fst (array_chop (Array.length args - 2) args)) + | _ -> typ + in aux init + in + let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ + in it_mkProd_or_LetIn ccl ctx + in + let typ = it_mkProd_or_LetIn typ ctx in + let cst = + { const_entry_body = term; + const_entry_type = Some typ; + const_entry_opaque = false; + const_entry_boxed = false } + in + ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) + +let build_morphism_signature m = + let env = Global.env () in + let m = Constrintern.interp_constr Evd.empty env m in + let t = Typing.type_of env Evd.empty m in + let isevars = ref (Evd.empty, Evd.empty) in + let cstrs = + let rec aux t = + match kind_of_term t with + | Prod (na, a, b) -> + None :: aux b + | _ -> [] + in aux t + in + let evars, t', sig_, cstrs = build_signature !isevars env t cstrs None snd in + let _ = isevars := evars in + let _ = List.iter + (fun (ty, rel) -> + Option.iter (fun rel -> + let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in + let evars,c = new_cstr_evar !isevars env default in + isevars := evars) + rel) + cstrs + in + let morph = + mkApp (Lazy.force proper_type, [| t; sig_; m |]) + in + let evd = solve_constraints env !isevars in + let m = Evarutil.nf_evar evd morph in + Evarutil.check_evars env Evd.empty evd m; m + +let default_morphism sign m = + let env = Global.env () in + let t = Typing.type_of env Evd.empty m in + let evars, _, sign, cstrs = + build_signature (Evd.empty,Evd.empty) env t (fst sign) (snd sign) (fun (ty, rel) -> rel) + in + let morph = + mkApp (Lazy.force proper_type, [| t; sign; m |]) + in + let evars, mor = resolve_one_typeclass env (merge_evars evars) morph in + mor, proper_projection mor morph + +let add_setoid binders a aeq t n = + init_setoid (); + let _lemma_refl = declare_instance_refl binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym = declare_instance_sym binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans = declare_instance_trans binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" + in ignore( + anew_instance binders instance + [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + +let add_morphism_infer glob m n = + init_setoid (); + let instance_id = add_suffix n "_Proper" in + let instance = build_morphism_signature m in + if Lib.is_modtype () then + let cst = Declare.declare_internal_constant instance_id + (Entries.ParameterEntry (instance,false), Decl_kinds.IsAssumption Decl_kinds.Logical) + in + add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + else + let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in + Flags.silently + (fun () -> + Lemmas.start_proof instance_id kind instance + (fun _ -> function + Libnames.ConstRef cst -> + add_instance (Typeclasses.new_instance (Lazy.force proper_class) None + glob (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + | _ -> assert false); + Pfedit.by (Tacinterp.interp <:tactic< Coq.Classes.SetoidTactics.add_morphism_tactic>>)) (); + Flags.if_verbose (fun x -> msg (Printer.pr_open_subgoals x)) () + +let add_morphism glob binders m s n = + init_setoid (); + let instance_id = add_suffix n "_Proper" in + let instance = + ((dummy_loc,Name instance_id), Explicit, + CAppExpl (dummy_loc, + (None, Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")), + [cHole; s; m])) + in + let tac = Tacinterp.interp <:tactic<add_morphism_tactic>> in + ignore(new_instance ~global:glob binders instance (CRecord (dummy_loc,None,[])) + ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) + +VERNAC COMMAND EXTEND AddSetoid1 + [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid [] a aeq t n ] + | [ "Add" "Parametric" "Setoid" binders_let(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid binders a aeq t n ] + | [ "Add" "Morphism" constr(m) ":" ident(n) ] -> + [ add_morphism_infer (not (Vernacexpr.use_section_locality ())) m n ] + | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] -> + [ add_morphism (not (Vernacexpr.use_section_locality ())) [] m s n ] + | [ "Add" "Parametric" "Morphism" binders_let(binders) ":" constr(m) + "with" "signature" lconstr(s) "as" ident(n) ] -> + [ add_morphism (not (Vernacexpr.use_section_locality ())) binders m s n ] +END + +(** Bind to "rewrite" too *) + +(** Taken from original setoid_replace, to emulate the old rewrite semantics where + lemmas are first instantiated and then rewrite proceeds. *) + +let check_evar_map_of_evars_defs evd = + let metas = Evd.meta_list evd in + let check_freemetas_is_empty rebus = + Evd.Metaset.iter + (fun m -> + if Evd.meta_defined evd m then () else + raise + (Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m]))) + in + List.iter + (fun (_,binding) -> + match binding with + Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> + check_freemetas_is_empty rebus freemetas + | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_), + {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> + check_freemetas_is_empty rebus1 freemetas1 ; + check_freemetas_is_empty rebus2 freemetas2 + ) metas + +let unification_rewrite l2r c1 c2 cl car rel but gl = + let env = pf_env gl in + let (evd',c') = + try + (* ~flags:(false,true) to allow to mark occurrences that must not be + rewritten simply by replacing them with let-defined definitions + in the context *) + Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env ((if l2r then c1 else c2),but) cl.evd + with + Pretype_errors.PretypeError _ -> + (* ~flags:(true,true) to make Ring work (since it really + exploits conversion) *) + Unification.w_unify_to_subterm ~flags:rewrite2_unif_flags + env ((if l2r then c1 else c2),but) cl.evd + in + let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in + let cl' = {cl with evd = evd'} in + let cl' = + let mvs = clenv_dependent false cl' in + clenv_pose_metas_as_evars cl' mvs + in + let nf c = Evarutil.nf_evar ( cl'.evd) (Clenv.clenv_nf_meta cl' c) in + let c1 = if l2r then nf c' else nf c1 + and c2 = if l2r then nf c2 else nf c' + and car = nf car and rel = nf rel in + check_evar_map_of_evars_defs cl'.evd; + let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in + let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in + {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)} + +let get_hyp gl evars c clause l2r = + let hi = decompose_applied_relation (pf_env gl) evars c l2r in + let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in + unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl + +let general_rewrite_flags = { under_lambdas = false; on_morphisms = false } + +let apply_lemma gl c cl l2r occs = + let sigma = project gl in + let hypinfo = ref (get_hyp gl sigma c cl l2r) in + let app = apply_rule hypinfo occs in + let rec aux () = + Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env)) + in !hypinfo, aux () + +let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = + let meta = Evarutil.new_meta() in + let hypinfo, strat = apply_lemma gl c cl l2r occs in + try + tclTHEN + (Refiner.tclEVARS hypinfo.cl.evd) + (cl_rewrite_clause_aux ~abs:hypinfo.abs strat meta cl) gl + with Not_found -> + let {l2r=l2r; c1=x; c2=y} = hypinfo in + raise (Pretype_errors.PretypeError + (pf_env gl, + Pretype_errors.NoOccurrenceFound ((if l2r then x else y), cl))) + +let general_s_rewrite_clause x = + init_setoid (); + match x with + | None -> general_s_rewrite None + | Some id -> general_s_rewrite (Some id) + +let _ = Equality.register_general_rewrite_clause general_s_rewrite_clause + +let is_loaded d = + let d' = List.map id_of_string d in + let dir = make_dirpath (List.rev d') in + Library.library_is_loaded dir + +let try_loaded f gl = + if is_loaded ["Coq";"Classes";"RelationClasses"] then f gl + else tclFAIL 0 (str"You need to require Coq.Classes.RelationClasses first") gl + +(** [setoid_]{reflexivity,symmetry,transitivity} tactics *) + +let not_declared env ty rel = + tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++ + str ty ++ str" relation. Maybe you need to require the Setoid library") + +let relation_of_constr env c = + match kind_of_term c with + | App (f, args) when Array.length args >= 2 -> + let relargs, args = array_chop (Array.length args - 2) args in + mkApp (f, relargs), args + | _ -> errorlabstrm "relation_of_constr" + (str "The term " ++ Printer.pr_constr_env env c ++ str" is not an applied relation.") + +let setoid_proof gl ty fn fallback = + let env = pf_env gl in + try + let rel, args = relation_of_constr env (pf_concl gl) in + let evm, car = project gl, pf_type_of gl args.(0) in + fn env evm car rel gl + with e -> + try fallback gl + with Hipattern.NoEquationFound -> + match e with + | Not_found -> + let rel, args = relation_of_constr env (pf_concl gl) in + not_declared env ty rel gl + | _ -> raise e + +let setoid_reflexivity gl = + setoid_proof gl "reflexive" + (fun env evm car rel -> apply (get_reflexive_proof env evm car rel)) + (reflexivity_red true) + +let setoid_symmetry gl = + setoid_proof gl "symmetric" + (fun env evm car rel -> apply (get_symmetric_proof env evm car rel)) + (symmetry_red true) + +let setoid_transitivity c gl = + setoid_proof gl "transitive" + (fun env evm car rel -> + let proof = get_transitive_proof env evm car rel in + match c with + | None -> eapply proof + | Some c -> + apply_with_bindings (proof,Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ])) + (transitivity_red true c) + +let setoid_symmetry_in id gl = + let ctype = pf_type_of gl (mkVar id) in + let binders,concl = decompose_prod_assum ctype in + let (equiv, args) = decompose_app concl in + let rec split_last_two = function + | [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 equivalence." + in + let others,(c1,c2) = split_last_two args in + let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in + let new_hyp' = mkApp (he, [| c2 ; c1 |]) in + let new_hyp = it_mkProd_or_LetIn new_hyp' binders in + tclTHENS (Tactics.cut new_hyp) + [ intro_replacing id; + tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ] ] + gl + +let _ = Tactics.register_setoid_reflexivity setoid_reflexivity +let _ = Tactics.register_setoid_symmetry setoid_symmetry +let _ = Tactics.register_setoid_symmetry_in setoid_symmetry_in +let _ = Tactics.register_setoid_transitivity setoid_transitivity + +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 + +let implify id gl = + let (_, b, ctype) = pf_get_hyp gl id in + let binders,concl = decompose_prod_assum ctype in + let ctype' = + match binders with + | (_, None, ty as hd) :: tl when noccurn 1 concl -> + let env = Environ.push_rel_context tl (pf_env gl) in + let sigma = project gl in + let tyhd = Typing.type_of env sigma ty + and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in + let app = mkApp (arrow_morphism tyhd (subst1 mkProp tyconcl), [| ty; (subst1 mkProp concl) |]) in + it_mkProd_or_LetIn app tl + | _ -> ctype + in convert_hyp_no_check (id, b, ctype') gl + +TACTIC EXTEND implify +[ "implify" hyp(n) ] -> [ implify n ] +END diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 5c891c58..87c88b9d 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -6,14 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacinterp.ml 13130 2010-06-13 18:45:09Z herbelin $ *) +(* $Id$ *) open Constrintern open Closure open RedFlags open Declarations open Entries -open Dyn open Libobject open Pattern open Matching @@ -26,6 +25,7 @@ open Names open Nameops open Libnames open Nametab +open Smartlocate open Pfedit open Proof_type open Refiner @@ -46,16 +46,17 @@ open Inductiveops open Syntax_def open Pretyping open Pretyping.Default +open Extrawit open Pcoq let safe_msgnl s = - try msgnl s with e -> - msgnl + try msgnl s with e -> + msgnl (str "bug in the debugger: " ++ str "an exception is raised while printing debug information") let error_syntactic_metavariables_not_allowed loc = - user_err_loc + user_err_loc (loc,"out_ident", str "Syntactic metavariables allowed only in quotations.") @@ -74,14 +75,15 @@ type ltac_type = type value = | VRTactic of (goal list sigma * validation) (* For Match results *) (* Not a true value *) - | VFun of ltac_trace * (identifier*value) list * + | VFun of ltac_trace * (identifier*value) list * identifier option list * glob_tactic_expr | VVoid | VInteger of int | VIntroPattern of intro_pattern_expr (* includes idents which are not *) (* bound as in "Intro H" but which may be bound *) (* later, as in "tac" in "Intro H; tac" *) - | VConstr of constr (* includes idents known to be bound and references *) + | VConstr of constr_under_binders + (* includes idents known to be bound and references *) | VConstr_context of constr | VList of value list | VRec of (identifier*value) list ref * glob_tactic_expr @@ -93,13 +95,13 @@ let catch_error call_trace tac g = | LtacLocated _ as e -> raise e | Stdpp.Exc_located (_,LtacLocated _) as e -> raise e | e -> - let (loc',c),tail = list_sep_last call_trace in + let (nrep,loc',c),tail = list_sep_last call_trace in let loc,e' = match e with Stdpp.Exc_located(loc,e) -> loc,e | _ ->dloc,e in if tail = [] then let loc = if loc = dloc then loc' else loc in raise (Stdpp.Exc_located(loc,e')) else - raise (Stdpp.Exc_located(loc',LtacLocated((c,tail,loc),e'))) + raise (Stdpp.Exc_located(loc',LtacLocated((nrep,c,tail,loc),e'))) (* Signature for interpretation: val_interp and interpretation functions *) type interp_sign = @@ -114,9 +116,6 @@ let check_is_value = function error "Immediate match producing tactics not allowed in local definitions." | _ -> () -(* For tactic_of_value *) -exception NotTactic - (* Gives the constr corresponding to a Constr_context tactic_arg *) let constr_of_VConstr_context = function | VConstr_context c -> c @@ -128,7 +127,10 @@ let rec pr_value env = function | VVoid -> str "()" | VInteger n -> int n | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat) - | VConstr c | VConstr_context c -> + | VConstr c -> + (match env with Some env -> + pr_lconstr_under_binders_env env c | _ -> str "a term") + | VConstr_context c -> (match env with Some env -> pr_lconstr_env env c | _ -> str "a term") | (VRTactic _ | VFun _ | VRec _) -> str "a tactic" | VList [] -> str "an empty list" @@ -136,21 +138,21 @@ let rec pr_value env = function str "a list (first element is " ++ pr_value env a ++ str")" (* Transforms an id into a constr if possible, or fails *) -let constr_of_id env id = +let constr_of_id env id = construct_reference (Environ.named_context env) id (* To embed tactics *) let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t), (tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr))) = - create "tactic" + Dyn.create "tactic" let ((value_in : value -> Dyn.t), - (value_out : Dyn.t -> value)) = create "value" + (value_out : Dyn.t -> value)) = Dyn.create "value" let valueIn t = TacDynamic (dummy_loc,value_in t) let valueOut = function | TacDynamic (_,d) -> - if (tag d) = "value" then + if (Dyn.tag d) = "value" then value_out d else anomalylabstrm "valueOut" (str "Dynamic tag should be value") @@ -176,11 +178,6 @@ let find_reference env qid = -> VarRef id | _ -> Nametab.locate qid -let error_not_evaluable s = - errorlabstrm "evalref_of_ref" - (str "Cannot coerce" ++ spc () ++ s ++ spc () ++ - str "to an evaluable reference.") - (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) let atomic_mactab = ref Idmap.empty let add_primitive_tactic s tac = @@ -205,8 +202,8 @@ let _ = "eleft", TacLeft(true,NoBindings); "right", TacRight(false,NoBindings); "eright", TacRight(true,NoBindings); - "split", TacSplit(false,false,NoBindings); - "esplit", TacSplit(true,false,NoBindings); + "split", TacSplit(false,false,[NoBindings]); + "esplit", TacSplit(true,false,[NoBindings]); "constructor", TacAnyConstructor (false,None); "econstructor", TacAnyConstructor (true,None); "reflexivity", TacReflexivity; @@ -218,7 +215,7 @@ let _ = "fail", TacFail(ArgArg 0,[]); "fresh", TacArg(TacFreshId []) ] - + let lookup_atomic id = Idmap.find id !atomic_mactab let is_atomic_kn kn = let (_,_,l) = repr_kn kn in @@ -236,9 +233,7 @@ let _ = Summary.declare_summary "tactic-definition" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; - Summary.init_function = init; - Summary.survive_module = false; - Summary.survive_section = false } + Summary.init_function = init } (* Tactics table (TacExtend). *) @@ -246,7 +241,7 @@ let tac_tab = Hashtbl.create 17 let add_tactic s t = if Hashtbl.mem tac_tab s then - errorlabstrm ("Refiner.add_tactic: ") + errorlabstrm ("Refiner.add_tactic: ") (str ("Cannot redeclare tactic "^s^".")); Hashtbl.add tac_tab s t @@ -258,9 +253,9 @@ let overwriting_add_tactic s t = Hashtbl.add tac_tab s t let lookup_tactic s = - try + try Hashtbl.find tac_tab s - with Not_found -> + with Not_found -> errorlabstrm "Refiner.lookup_tactic" (str"The tactic " ++ str s ++ str" is not installed.") (* @@ -279,7 +274,7 @@ type glob_sign = { type interp_genarg_type = (glob_sign -> raw_generic_argument -> glob_generic_argument) * - (interp_sign -> goal sigma -> glob_generic_argument -> + (interp_sign -> goal sigma -> glob_generic_argument -> typed_generic_argument) * (substitution -> glob_generic_argument -> glob_generic_argument) @@ -287,24 +282,34 @@ let extragenargtab = ref (Gmap.empty : (string,interp_genarg_type) Gmap.t) let add_interp_genarg id f = extragenargtab := Gmap.add id f !extragenargtab -let lookup_genarg id = +let lookup_genarg id = try Gmap.find id !extragenargtab - with Not_found -> failwith ("No interpretation function found for entry "^id) + with Not_found -> + let msg = "No interpretation function found for entry " ^ id in + warning msg; + let f = (fun _ _ -> failwith msg), (fun _ _ _ -> failwith msg), (fun _ a -> a) in + add_interp_genarg id f; + f + let lookup_genarg_glob id = let (f,_,_) = lookup_genarg id in f let lookup_interp_genarg id = let (_,f,_) = lookup_genarg id in f let lookup_genarg_subst id = let (_,_,f) = lookup_genarg id in f +let push_trace (loc,ck) = function + | (n,loc',ck')::trl when ck=ck' -> (n+1,loc,ck)::trl + | trl -> (1,loc,ck)::trl + let propagate_trace ist loc id = function | VFun (_,lfun,it,b) -> let t = if it=[] then b else TacFun (it,b) in - VFun ((loc,LtacVarCall (id,t))::ist.trace,lfun,it,b) + VFun (push_trace(loc,LtacVarCall (id,t)) ist.trace,lfun,it,b) | x -> x (* Dynamically check that an argument is a tactic *) let coerce_to_tactic loc id = function | VFun _ | VRTactic _ as a -> a - | _ -> user_err_loc + | _ -> user_err_loc (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") (*****************) @@ -313,23 +318,23 @@ let coerce_to_tactic loc id = function (* We have identifier <| global_reference <| constr *) -let find_ident id sign = - List.mem id (fst sign.ltacvars) or - List.mem id (ids_of_named_context (Environ.named_context sign.genv)) +let find_ident id ist = + List.mem id (fst ist.ltacvars) or + List.mem id (ids_of_named_context (Environ.named_context ist.genv)) -let find_recvar qid sign = List.assoc qid sign.ltacrecvars +let find_recvar qid ist = List.assoc qid ist.ltacrecvars (* a "var" is a ltac var or a var introduced by an intro tactic *) -let find_var id sign = List.mem id (fst sign.ltacvars) +let find_var id ist = List.mem id (fst ist.ltacvars) (* a "ctxvar" is a var introduced by an intro tactic (Intro/LetTac/...) *) -let find_ctxvar id sign = List.mem id (snd sign.ltacvars) +let find_ctxvar id ist = List.mem id (snd ist.ltacvars) (* a "ltacvar" is an ltac var (Let-In/Fun/...) *) -let find_ltacvar id sign = find_var id sign & not (find_ctxvar id sign) +let find_ltacvar id ist = find_var id ist & not (find_ctxvar id ist) -let find_hyp id sign = - List.mem id (ids_of_named_context (Environ.named_context sign.genv)) +let find_hyp id ist = + List.mem id (ids_of_named_context (Environ.named_context ist.genv)) (* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *) (* be fresh in which case it is binding later on *) @@ -348,7 +353,7 @@ let vars_of_ist (lfun,_,_,env) = let get_current_context () = try Pfedit.get_current_goal_context () - with e when Logic.catchable_exception e -> + with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) let strict_check = ref false @@ -370,17 +375,7 @@ let intern_or_var ist = function | ArgVar locid -> ArgVar (intern_hyp ist locid) | ArgArg _ as x -> x -let loc_of_by_notation f = function - | AN c -> f c - | ByNotation (loc,s,_) -> loc - -let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" - -let intern_inductive_or_by_notation = function - | AN r -> Nametab.inductive_of_reference r - | ByNotation (loc,ntn,sc) -> - destIndRef (Notation.interp_notation_as_global_reference loc - (function IndRef ind -> true | _ -> false) ntn sc) +let intern_inductive_or_by_notation = smart_global_inductive let intern_inductive ist = function | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id) @@ -388,10 +383,10 @@ let intern_inductive ist = function let intern_global_reference ist = function | Ident (loc,id) when find_var id ist -> ArgVar (loc,id) - | r -> + | r -> let loc,_ as lqid = qualid_of_reference r in try ArgArg (loc,locate_global_with_alias lqid) - with Not_found -> + with Not_found -> error_global_not_found_loc lqid let intern_ltac_variable ist = function @@ -486,7 +481,9 @@ let rec intern_intro_pattern lf ist = function loc, IntroOrAndPattern (intern_or_and_intro_pattern lf ist l) | loc, IntroIdentifier id -> loc, IntroIdentifier (intern_ident lf ist id) - | loc, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _) + | loc, IntroFresh id -> + loc, IntroFresh (intern_ident lf ist id) + | loc, (IntroWildcard | IntroAnonymous | IntroRewrite _ | IntroForthcoming _) as x -> x and intern_or_and_intro_pattern lf ist = @@ -497,22 +494,22 @@ let intern_quantified_hypothesis ist = function | NamedHyp id -> (* Uncomment to disallow "intros until n" in ltac when n is not bound *) NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*)) - + let intern_binding_name ist x = (* We use identifier both for variables and binding names *) - (* Todo: consider the body of the lemma to which the binding refer + (* Todo: consider the body of the lemma to which the binding refer and if a term w/o ltac vars, check the name is indeed quantified *) x -let intern_constr_gen isarity {ltacvars=lfun; gsigma=sigma; genv=env} c = +let intern_constr_gen allow_patvar isarity {ltacvars=lfun; gsigma=sigma; genv=env} c = let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in - let c' = - warn (Constrintern.intern_gen isarity ~ltacvars:(fst lfun,[]) sigma env) c + let c' = + warn (Constrintern.intern_gen isarity ~allow_patvar ~ltacvars:(fst lfun,[]) sigma env) c in (c',if !strict_check then None else Some c) -let intern_constr = intern_constr_gen false -let intern_type = intern_constr_gen true +let intern_constr = intern_constr_gen false false +let intern_type = intern_constr_gen false true (* Globalize bindings *) let intern_binding ist (loc,b,c) = @@ -545,38 +542,33 @@ let intern_induction_arg ist = function else ElimOnIdent (loc,id) -let evaluable_of_global_reference = function - | ConstRef c -> EvalConstRef c - | VarRef c -> EvalVarRef c - | r -> error_not_evaluable (pr_global r) - let short_name = function | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id) | _ -> None -let interp_global_reference r = +let intern_evaluable_global_reference ist r = let lqid = qualid_of_reference r in - try locate_global_with_alias lqid + try evaluable_of_global_reference ist.genv (locate_global_with_alias lqid) with Not_found -> - match r with - | Ident (loc,id) when not !strict_check -> VarRef id + match r with + | Ident (loc,id) when not !strict_check -> EvalVarRef id | _ -> error_global_not_found_loc lqid -let intern_evaluable_reference_or_by_notation = function - | AN r -> evaluable_of_global_reference (interp_global_reference r) +let intern_evaluable_reference_or_by_notation ist = function + | AN r -> intern_evaluable_global_reference ist r | ByNotation (loc,ntn,sc) -> - evaluable_of_global_reference + evaluable_of_global_reference ist.genv (Notation.interp_notation_as_global_reference loc (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) -(* Globalizes a reduction expression *) +(* Globalize a reduction expression *) let intern_evaluable ist = function | AN (Ident (loc,id)) when find_ltacvar id ist -> ArgVar (loc,id) | AN (Ident (_,id)) when (not !strict_check & find_hyp id ist) or find_ctxvar id ist -> ArgArg (EvalVarRef id, None) | r -> - let e = intern_evaluable_reference_or_by_notation r in + let e = intern_evaluable_reference_or_by_notation ist r in let na = short_name r in ArgArg (e,na) @@ -587,15 +579,31 @@ let intern_flag ist red = let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c) +let intern_constr_pattern ist ltacvars pc = + let metas,pat = + Constrintern.intern_constr_pattern ist.gsigma ist.genv ~ltacvars pc in + let c = intern_constr_gen true false ist pc in + metas,(c,pat) + +let intern_typed_pattern ist p = + let dummy_pat = PRel 0 in + (* we cannot ensure in non strict mode that the pattern is closed *) + (* keeping a constr_expr copy is too complicated and we want anyway to *) + (* type it, so we remember the pattern as a rawconstr only *) + (intern_constr_gen true false ist p,dummy_pat) + +let intern_typed_pattern_with_occurrences ist (l,p) = + (l,intern_typed_pattern ist p) + let intern_red_expr ist = function | Unfold l -> Unfold (List.map (intern_unfold ist) l) | Fold l -> Fold (List.map (intern_constr ist) l) | Cbv f -> Cbv (intern_flag ist f) | Lazy f -> Lazy (intern_flag ist f) | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l) - | Simpl o -> Simpl (Option.map (intern_constr_with_occurrences ist) o) + | Simpl o -> Simpl (Option.map (intern_typed_pattern_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r ) -> r - + let intern_in_hyp_as ist lf (id,ipat) = (intern_hyp_or_metaid ist id, Option.map (intern_intro_pattern lf ist) ipat) @@ -616,15 +624,15 @@ let intern_hyp_location ist (((b,occs),id),hl) = (((b,List.map (intern_or_var ist) occs),intern_hyp_or_metaid ist id), hl) (* Reads a pattern *) -let intern_pattern sigma env ?(as_type=false) lfun = function +let intern_pattern ist ?(as_type=false) lfun = function | Subterm (b,ido,pc) -> let ltacvars = (lfun,[]) in - let (metas,pat) = intern_constr_pattern sigma env ~ltacvars pc in - ido, metas, Subterm (b,ido,pat) + let (metas,pc) = intern_constr_pattern ist ltacvars pc in + ido, metas, Subterm (b,ido,pc) | Term pc -> let ltacvars = (lfun,[]) in - let (metas,pat) = intern_constr_pattern sigma env ~as_type ~ltacvars pc in - None, metas, Term pat + let (metas,pc) = intern_constr_pattern ist ltacvars pc in + None, metas, Term pc let intern_constr_may_eval ist = function | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c) @@ -640,10 +648,10 @@ let declare_xml_printer f = print_xml_term := f let internalise_tacarg ch = G_xml.parse_tactic_arg ch let extern_tacarg ch env sigma = function - | VConstr c -> !print_xml_term ch env sigma c + | VConstr ([],c) -> !print_xml_term ch env sigma c | VRTactic _ | VFun _ | VVoid | VInteger _ | VConstr_context _ - | VIntroPattern _ | VRec _ | VList _ -> - error "Only externing of terms is implemented." + | VIntroPattern _ | VRec _ | VList _ | VConstr _ -> + error "Only externing of closed terms is implemented." let extern_request ch req gl la = output_string ch "<REQUEST req=\""; output_string ch req; @@ -651,24 +659,33 @@ let extern_request ch req gl la = List.iter (pf_apply (extern_tacarg ch) gl) la; output_string ch "</REQUEST>\n" +let value_of_ident id = VIntroPattern (IntroIdentifier id) + +let extend_values_with_bindings (ln,lm) lfun = + let lnames = List.map (fun (id,id') ->(id,value_of_ident id')) ln in + let lmatch = List.map (fun (id,(ids,c)) -> (id,VConstr (ids,c))) lm in + (* For compatibility, bound variables are visible only if no other + binding of the same name exists *) + lmatch@lfun@lnames + (* Reads the hypotheses of a "match goal" rule *) -let rec intern_match_goal_hyps sigma env lfun = function +let rec intern_match_goal_hyps ist lfun = function | (Hyp ((_,na) as locna,mp))::tl -> - let ido, metas1, pat = intern_pattern sigma env ~as_type:true lfun mp in - let lfun, metas2, hyps = intern_match_goal_hyps sigma env lfun tl in + let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in + let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in let lfun' = name_cons na (Option.List.cons ido lfun) in lfun', metas1@metas2, Hyp (locna,pat)::hyps | (Def ((_,na) as locna,mv,mp))::tl -> - let ido, metas1, patv = intern_pattern sigma env ~as_type:false lfun mv in - let ido', metas2, patt = intern_pattern sigma env ~as_type:true lfun mp in - let lfun, metas3, hyps = intern_match_goal_hyps sigma env lfun tl in + let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in + let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in + let lfun, metas3, hyps = intern_match_goal_hyps ist lfun tl in let lfun' = name_cons na (Option.List.cons ido' (Option.List.cons ido lfun)) in lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps | [] -> lfun, [], [] (* Utilities *) let extract_let_names lrc = - List.fold_right + List.fold_right (fun ((loc,name),_) l -> if List.mem name l then user_err_loc @@ -684,7 +701,7 @@ let clause_app f = function (* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *) let rec intern_atomic lf ist x = - match (x:raw_atomic_tactic_expr) with + match (x:raw_atomic_tactic_expr) with (* Basic tactics *) | TacIntroPattern l -> TacIntroPattern (List.map (intern_intro_pattern lf ist) l) @@ -717,7 +734,7 @@ let rec intern_atomic lf ist x = | TacAssert (otac,ipat,c) -> TacAssert (Option.map (intern_tactic ist) otac, Option.map (intern_intro_pattern lf ist) ipat, - intern_constr_gen (otac<>None) ist c) + intern_constr_gen false (otac<>None) ist c) | TacGeneralize cl -> TacGeneralize (List.map (fun (c,na) -> intern_constr_with_occurrences ist c, @@ -744,13 +761,13 @@ let rec intern_atomic lf ist x = (* Derived basic tactics *) | TacSimpleInductionDestruct (isrec,h) -> TacSimpleInductionDestruct (isrec,intern_quantified_hypothesis ist h) - | TacInductionDestruct (ev,isrec,l) -> - TacInductionDestruct (ev,isrec,List.map (fun (lc,cbo,(ipato,ipats),cls) -> + | TacInductionDestruct (ev,isrec,(l,cls)) -> + TacInductionDestruct (ev,isrec,(List.map (fun (lc,cbo,(ipato,ipats)) -> (List.map (intern_induction_arg ist) lc, Option.map (intern_constr_with_bindings ist) cbo, (Option.map (intern_intro_pattern lf ist) ipato, - Option.map (intern_intro_pattern lf ist) ipats), - Option.map (clause_app (intern_hyp_location ist)) cls)) l) + Option.map (intern_intro_pattern lf ist) ipats))) l, + Option.map (clause_app (intern_hyp_location ist)) cls)) | TacDoubleInduction (h1,h2) -> let h1 = intern_quantified_hypothesis ist h1 in let h2 = intern_quantified_hypothesis ist h2 in @@ -767,40 +784,43 @@ let rec intern_atomic lf ist x = | TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l) | TacMove (dep,id1,id2) -> TacMove (dep,intern_hyp_or_metaid ist id1,intern_move_location ist id2) - | TacRename l -> - TacRename (List.map (fun (id1,id2) -> - intern_hyp_or_metaid ist id1, + | TacRename l -> + TacRename (List.map (fun (id1,id2) -> + intern_hyp_or_metaid ist id1, intern_hyp_or_metaid ist id2) l) | TacRevert l -> TacRevert (List.map (intern_hyp_or_metaid ist) l) - + (* Constructors *) | TacLeft (ev,bl) -> TacLeft (ev,intern_bindings ist bl) | TacRight (ev,bl) -> TacRight (ev,intern_bindings ist bl) - | TacSplit (ev,b,bl) -> TacSplit (ev,b,intern_bindings ist bl) + | TacSplit (ev,b,bll) -> TacSplit (ev,b,List.map (intern_bindings ist) bll) | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (intern_tactic ist) t) | TacConstructor (ev,n,bl) -> TacConstructor (ev,n,intern_bindings ist bl) (* Conversion *) | TacReduce (r,cl) -> TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) - | TacChange (occl,c,cl) -> - TacChange (Option.map (intern_constr_with_occurrences ist) occl, - (if occl = None & (cl.onhyps = None or cl.onhyps = Some []) & + | TacChange (None,c,cl) -> + TacChange (None, + (if (cl.onhyps = None or cl.onhyps = Some []) & (cl.concl_occs = all_occurrences_expr or cl.concl_occs = no_occurrences_expr) then intern_type ist c else intern_constr ist c), clause_app (intern_hyp_location ist) cl) + | TacChange (Some p,c,cl) -> + TacChange (Some (intern_typed_pattern ist p),intern_constr ist c, + clause_app (intern_hyp_location ist) cl) (* Equivalence relations *) | TacReflexivity -> TacReflexivity - | TacSymmetry idopt -> + | TacSymmetry idopt -> TacSymmetry (clause_app (intern_hyp_location ist) idopt) - | TacTransitivity c -> TacTransitivity (intern_constr ist c) + | TacTransitivity c -> TacTransitivity (Option.map (intern_constr ist) c) (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - TacRewrite - (ev, + | TacRewrite (ev,l,cl,by) -> + TacRewrite + (ev, List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings ist c)) l, clause_app (intern_hyp_location ist) cl, Option.map (intern_tactic ist) by) @@ -827,7 +847,7 @@ and intern_tactic_seq ist = function | TacLetIn (isrec,l,u) -> let (l1,l2) = ist.ltacvars in let ist' = { ist with ltacvars = (extract_let_names l @ l1, l2) } in - let l = List.map (fun (n,b) -> + let l = List.map (fun (n,b) -> (n,intern_tacarg !strict_check (if isrec then ist' else ist) b)) l in ist.ltacvars, TacLetIn (isrec,l,intern_tactic ist' u) | TacMatchGoal (lz,lr,lmr) -> @@ -835,7 +855,7 @@ and intern_tactic_seq ist = function | TacMatch (lz,c,lmr) -> ist.ltacvars, TacMatch (lz,intern_tactic ist c,intern_match_rule ist lmr) | TacId l -> ist.ltacvars, TacId (intern_message ist l) - | TacFail (n,l) -> + | TacFail (n,l) -> ist.ltacvars, TacFail (intern_or_var ist n,intern_message ist l) | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac) | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s) @@ -854,7 +874,7 @@ and intern_tactic_seq ist = function let ist' = { ist with ltacvars = lfun' } in (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) lfun', TacThens (t, List.map (intern_tactic ist') tl) - | TacDo (n,tac) -> + | TacDo (n,tac) -> ist.ltacvars, TacDo (intern_or_var ist n,intern_tactic ist tac) | TacTry tac -> ist.ltacvars, TacTry (intern_tactic ist tac) | TacInfo tac -> ist.ltacvars, TacInfo (intern_tactic ist tac) @@ -866,7 +886,7 @@ and intern_tactic_seq ist = function | TacComplete tac -> ist.ltacvars, TacComplete (intern_tactic ist tac) | TacArg a -> ist.ltacvars, TacArg (intern_tacarg true ist a) -and intern_tactic_fun ist (var,body) = +and intern_tactic_fun ist (var,body) = let (l1,l2) = ist.ltacvars in let lfun' = List.rev_append (Option.List.flatten var) l1 in (var,intern_tactic { ist with ltacvars = (lfun',l2) } body) @@ -874,7 +894,7 @@ and intern_tactic_fun ist (var,body) = and intern_tacarg strict ist = function | TacVoid -> TacVoid | Reference r -> intern_non_tactic_reference strict ist r - | IntroPattern ipat -> + | IntroPattern ipat -> let lf = ref([],[]) in (*How to know what names the intropattern binds?*) IntroPattern (intern_intro_pattern lf ist ipat) | Integer n -> Integer n @@ -891,12 +911,12 @@ and intern_tacarg strict ist = function TacCall (loc, intern_applied_tactic_reference ist f, List.map (intern_tacarg !strict_check ist) l) - | TacExternal (loc,com,req,la) -> + | TacExternal (loc,com,req,la) -> TacExternal (loc,com,req,List.map (intern_tacarg !strict_check ist) la) | TacFreshId x -> TacFreshId (List.map (intern_or_var ist) x) | Tacexp t -> Tacexp (intern_tactic ist t) | TacDynamic(loc,t) as x -> - (match tag t with + (match Dyn.tag t with | "tactic" | "value" | "constr" -> x | s -> anomaly_loc (loc, "", str "Unknown dynamic: <" ++ str s ++ str ">")) @@ -907,8 +927,8 @@ and intern_match_rule ist = function All (intern_tactic ist tc) :: (intern_match_rule ist tl) | (Pat (rl,mp,tc))::tl -> let {ltacvars=(lfun,l2); gsigma=sigma; genv=env} = ist in - let lfun',metas1,hyps = intern_match_goal_hyps sigma env lfun rl in - let ido,metas2,pat = intern_pattern sigma env lfun mp in + let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in + let ido,metas2,pat = intern_pattern ist lfun mp in let metas = list_uniquize (metas1@metas2) in let ist' = { ist with ltacvars = (metas@(Option.List.cons ido lfun'),l2) } in Pat (hyps,pat,intern_tactic ist' tc) :: (intern_match_rule ist tl) @@ -932,7 +952,7 @@ and intern_genarg ist x = (intern_intro_pattern lf ist (out_gen rawwit_intro_pattern x)) | IdentArgType b -> let lf = ref ([],[]) in - in_gen (globwit_ident_gen b) + in_gen (globwit_ident_gen b) (intern_ident lf ist (out_gen (rawwit_ident_gen b) x)) | VarArgType -> in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x)) @@ -943,7 +963,7 @@ and intern_genarg ist x = | ConstrArgType -> in_gen globwit_constr (intern_constr ist (out_gen rawwit_constr x)) | ConstrMayEvalArgType -> - in_gen globwit_constr_may_eval + in_gen globwit_constr_may_eval (intern_constr_may_eval ist (out_gen rawwit_constr_may_eval x)) | QuantHypArgType -> in_gen globwit_quant_hyp @@ -965,7 +985,7 @@ and intern_genarg ist x = | PairArgType _ -> app_pair (intern_genarg ist) (intern_genarg ist) x | ExtraArgType s -> match tactic_genarg_level s with - | Some n -> + | Some n -> (* Special treatment of tactic arguments *) in_gen (globwit_tactic n) (intern_tactic ist (out_gen (rawwit_tactic n) x)) @@ -977,159 +997,8 @@ and intern_genarg ist x = (***************************************************************************) (* Evaluation/interpretation *) -(* Associates variables with values and gives the remaining variables and - values *) -let head_with_value (lvar,lval) = - let rec head_with_value_rec lacc = function - | ([],[]) -> (lacc,[],[]) - | (vr::tvr,ve::tve) -> - (match vr with - | None -> head_with_value_rec lacc (tvr,tve) - | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) - | (vr,[]) -> (lacc,vr,[]) - | ([],ve) -> (lacc,[],ve) - in - head_with_value_rec [] (lvar,lval) - -(* Gives a context couple if there is a context identifier *) -let give_context ctxt = function - | None -> [] - | Some id -> [id,VConstr_context ctxt] - -(* Reads a pattern by substituting vars of lfun *) -let eval_pattern lfun c = - let lvar = List.map (fun (id,c) -> (id,lazy(pattern_of_constr c))) lfun in - instantiate_pattern lvar c - -let read_pattern lfun = function - | Subterm (b,ido,pc) -> Subterm (b,ido,eval_pattern lfun pc) - | Term pc -> Term (eval_pattern lfun pc) - -let value_of_ident id = VIntroPattern (IntroIdentifier id) - -let extend_values_with_bindings (ln,lm) lfun = - let lnames = List.map (fun (id,id') ->(id,value_of_ident id')) ln in - let lmatch = List.map (fun (id,c) -> (id,VConstr c)) lm in - (* For compatibility, bound variables are visible only if no other - binding of the same name exists *) - lmatch@lfun@lnames - -(* Reads the hypotheses of a Match Context rule *) -let cons_and_check_name id l = - if List.mem id l then - user_err_loc (dloc,"read_match_goal_hyps", - strbrk ("Hypothesis pattern-matching variable "^(string_of_id id)^ - " used twice in the same pattern.")) - else id::l - -let rec read_match_goal_hyps lfun lidh = function - | (Hyp ((loc,na) as locna,mp))::tl -> - let lidh' = name_fold cons_and_check_name na lidh in - Hyp (locna,read_pattern lfun mp):: - (read_match_goal_hyps lfun lidh' tl) - | (Def ((loc,na) as locna,mv,mp))::tl -> - let lidh' = name_fold cons_and_check_name na lidh in - Def (locna,read_pattern lfun mv, read_pattern lfun mp):: - (read_match_goal_hyps lfun lidh' tl) - | [] -> [] - -(* Reads the rules of a Match Context or a Match *) -let rec read_match_rule lfun = function - | (All tc)::tl -> (All tc)::(read_match_rule lfun tl) - | (Pat (rl,mp,tc))::tl -> - Pat (read_match_goal_hyps lfun [] rl, read_pattern lfun mp,tc) - :: read_match_rule lfun tl - | [] -> [] - -(* For Match Context and Match *) -exception Not_coherent_metas -exception Eval_fail of std_ppcmds - -let is_match_catchable = function - | PatternMatchingFailure | Eval_fail _ -> true - | e -> Logic.catchable_exception e - -(* Verifies if the matched list is coherent with respect to lcm *) -(* While non-linear matching is modulo eq_constr in matches, merge of *) -(* different instances of the same metavars is here modulo conversion... *) -let verify_metas_coherence gl (ln1,lcm) (ln,lm) = - let rec aux = function - | (num,csr)::tl -> - if (List.for_all (fun (a,b) -> a<>num or pf_conv_x gl b csr) lcm) then - (num,csr)::aux tl - else - raise Not_coherent_metas - | [] -> lcm in - (ln@ln1,aux lm) - -(* Tries to match one hypothesis pattern with a list of hypotheses *) -let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps = - let get_id_couple id = function - | Name idpat -> [idpat,VConstr (mkVar id)] - | Anonymous -> [] in - let match_pat lmatch hyp pat = - match pat with - | Term t -> - let lmeta = extended_matches t hyp in - (try - let lmeta = verify_metas_coherence gl lmatch lmeta in - ([],lmeta,(fun () -> raise PatternMatchingFailure)) - with - | Not_coherent_metas -> raise PatternMatchingFailure); - | Subterm (b,ic,t) -> - let rec match_next_pattern find_next () = - let (lmeta,ctxt,find_next') = find_next () in - try - let lmeta = verify_metas_coherence gl lmatch lmeta in - (give_context ctxt ic,lmeta,match_next_pattern find_next') - with - | Not_coherent_metas -> match_next_pattern find_next' () in - match_next_pattern(fun () -> match_subterm_gen b t hyp) () in - let rec apply_one_mhyp_context_rec = function - | (id,b,hyp as hd)::tl -> - (match patv with - | None -> - let rec match_next_pattern find_next () = - try - let (ids, lmeta, find_next') = find_next () in - (get_id_couple id hypname@ids, lmeta, hd, - match_next_pattern find_next') - with - | PatternMatchingFailure -> apply_one_mhyp_context_rec tl in - match_next_pattern (fun () -> - let hyp = if b<>None then refresh_universes_strict hyp else hyp in - match_pat lmatch hyp pat) () - | Some patv -> - match b with - | Some body -> - let rec match_next_pattern_in_body next_in_body () = - try - let (ids,lmeta,next_in_body') = next_in_body() in - let rec match_next_pattern_in_typ next_in_typ () = - try - let (ids',lmeta',next_in_typ') = next_in_typ() in - (get_id_couple id hypname@ids@ids', lmeta', hd, - match_next_pattern_in_typ next_in_typ') - with - | PatternMatchingFailure -> - match_next_pattern_in_body next_in_body' () in - match_next_pattern_in_typ - (fun () -> - let hyp = refresh_universes_strict hyp in - match_pat lmeta hyp pat) () - with PatternMatchingFailure -> apply_one_mhyp_context_rec tl - in - match_next_pattern_in_body - (fun () -> match_pat lmatch body patv) () - | None -> apply_one_mhyp_context_rec tl) - | [] -> - db_hyp_pattern_failure ist.debug env (hypname,pat); - raise PatternMatchingFailure - in - apply_one_mhyp_context_rec lhyps - let constr_to_id loc = function - | VConstr c when isVar c -> destVar c + | VConstr ([],c) when isVar c -> destVar c | _ -> invalid_arg_loc (loc, "Not an identifier") let constr_to_qid loc c = @@ -1158,12 +1027,12 @@ let debugging_exception_step ist signal_anomaly e pp = let explain_exc = if signal_anomaly then explain_logic_error else explain_logic_error_no_anomaly in - debugging_step ist (fun () -> + debugging_step ist (fun () -> pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ !explain_exc e) let error_ltac_variable loc id env v s = - user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ - strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ + user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ + strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ strbrk "which cannot be coerced to " ++ str s ++ str".") exception CannotCoerceTo of string @@ -1180,27 +1049,28 @@ let interp_ltac_var coerce ist env locid = (* Interprets an identifier which must be fresh *) let coerce_to_ident fresh env = function | VIntroPattern (IntroIdentifier id) -> id - | VConstr c when isVar c & not (fresh & is_variable env (destVar c)) -> + | VConstr ([],c) when isVar c & not (fresh & is_variable env (destVar c)) -> (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *) destVar c | v -> raise (CannotCoerceTo "a fresh identifier") -let interp_ident_gen fresh ist gl id = - let env = pf_env gl in +let interp_ident_gen fresh ist env id = try try_interp_ltac_var (coerce_to_ident fresh env) ist (Some env) (dloc,id) with Not_found -> id -let interp_ident = interp_ident_gen false +let interp_ident = interp_ident_gen false let interp_fresh_ident = interp_ident_gen true +let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl) +let pf_interp_fresh_ident id gl = interp_ident_gen true id (pf_env gl) (* Interprets an optional identifier which must be fresh *) -let interp_fresh_name ist gl = function +let interp_fresh_name ist env = function | Anonymous -> Anonymous - | Name id -> Name (interp_fresh_ident ist gl id) + | Name id -> Name (interp_fresh_ident ist env id) let coerce_to_intro_pattern env = function | VIntroPattern ipat -> ipat - | VConstr c when isVar c -> + | VConstr ([],c) when isVar c -> (* This happens e.g. in definitions like "Tac H = clear H; intro H" *) (* but also in "destruct H as (H,H')" *) IntroIdentifier (destVar c) @@ -1237,7 +1107,7 @@ let int_or_var_list_of_VList = function | _ -> raise Not_found let interp_int_or_var_as_list ist = function - | ArgVar (_,id as locid) -> + | ArgVar (_,id as locid) -> (try int_or_var_list_of_VList (List.assoc id ist.lfun) with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)]) | ArgArg n as x -> [x] @@ -1247,11 +1117,16 @@ let interp_int_or_var_list ist l = let constr_of_value env = function | VConstr csr -> csr - | VIntroPattern (IntroIdentifier id) -> constr_of_id env id + | VIntroPattern (IntroIdentifier id) -> ([],constr_of_id env id) | _ -> raise Not_found +let closed_constr_of_value env v = + let ids,c = constr_of_value env v in + if ids <> [] then raise Not_found; + c + let coerce_to_hyp env = function - | VConstr c when isVar c -> destVar c + | VConstr ([],c) when isVar c -> destVar c | VIntroPattern (IntroIdentifier id) when is_variable env id -> id | _ -> raise (CannotCoerceTo "a variable") @@ -1260,7 +1135,7 @@ let interp_hyp ist gl (loc,id as locid) = let env = pf_env gl in (* Look first in lfun for a value coercible to a variable *) try try_interp_ltac_var (coerce_to_hyp env) ist (Some env) locid - with Not_found -> + with Not_found -> (* Then look if bound in the proof context at calling time *) if is_variable env id then id else user_err_loc (loc,"eval_variable",pr_id id ++ str " not found.") @@ -1294,19 +1169,19 @@ let interp_move_location ist gl = function (* Interprets a qualified name *) let coerce_to_reference env v = try match v with - | VConstr c -> global_of_constr c (* may raise Not_found *) + | VConstr ([],c) -> global_of_constr c (* may raise Not_found *) | _ -> raise Not_found with Not_found -> raise (CannotCoerceTo "a reference") let interp_reference ist env = function | ArgArg (_,r) -> r - | ArgVar locid -> + | ArgVar locid -> interp_ltac_var (coerce_to_reference env) ist (Some env) locid let pf_interp_reference ist gl = interp_reference ist (pf_env gl) let coerce_to_inductive = function - | VConstr c when isInd c -> destInd c + | VConstr ([],c) when isInd c -> destInd c | _ -> raise (CannotCoerceTo "an inductive type") let interp_inductive ist = function @@ -1315,9 +1190,9 @@ let interp_inductive ist = function let coerce_to_evaluable_ref env v = let ev = match v with - | VConstr c when isConst c -> EvalConstRef (destConst c) - | VConstr c when isVar c -> EvalVarRef (destVar c) - | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env) + | VConstr ([],c) when isConst c -> EvalConstRef (destConst c) + | VConstr ([],c) when isVar c -> EvalVarRef (destVar c) + | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env) -> EvalVarRef id | _ -> raise (CannotCoerceTo "an evaluable reference") in @@ -1331,13 +1206,13 @@ let interp_evaluable ist env = function (* Maybe [id] has been introduced by Intro-like tactics *) (try match Environ.lookup_named id env with | (_,Some _,_) -> EvalVarRef id - | _ -> error_not_evaluable (pr_id id) + | _ -> error_not_evaluable (VarRef id) with Not_found -> match r with | EvalConstRef _ -> r | _ -> Pretype_errors.error_var_not_found_loc loc id) | ArgArg (r,None) -> r - | ArgVar locid -> + | ArgVar locid -> interp_ltac_var (coerce_to_evaluable_ref env) ist (Some env) locid (* Interprets an hypothesis name *) @@ -1354,25 +1229,26 @@ let interp_clause ist gl { onhyps=ol; concl_occs=occs } = (* Interpretation of constructions *) (* Extract the constr list from lfun *) -let rec constr_list_aux env = function - | (id,v)::tl -> - let (l1,l2) = constr_list_aux env tl in +let extract_ltac_constr_values ist env = + let rec aux = function + | (id,v)::tl -> + let (l1,l2) = aux tl in (try ((id,constr_of_value env v)::l1,l2) - with Not_found -> + with Not_found -> let ido = match v with | VIntroPattern (IntroIdentifier id0) -> Some id0 | _ -> None in (l1,(id,ido)::l2)) - | [] -> ([],[]) - -let constr_list ist env = constr_list_aux env ist.lfun + | [] -> ([],[]) in + aux ist.lfun (* Extract the identifier list from lfun: join all branches (what to do else?)*) let rec intropattern_ids (loc,pat) = match pat with | IntroIdentifier id -> [id] - | IntroOrAndPattern ll -> + | IntroOrAndPattern ll -> List.flatten (List.map intropattern_ids (List.flatten ll)) - | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ -> [] + | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ + | IntroForthcoming _ -> [] let rec extract_ids ids = function | (id,VIntroPattern ipat)::tl when not (List.mem id ids) -> @@ -1382,33 +1258,21 @@ let rec extract_ids ids = function let default_fresh_id = id_of_string "H" -let interp_fresh_id ist gl l = +let interp_fresh_id ist env l = let ids = map_succeed (function ArgVar(_,id) -> id | _ -> failwith "") l in let avoid = (extract_ids ids ist.lfun) @ ist.avoid_ids in - let id = - if l = [] then default_fresh_id + let id = + if l = [] then default_fresh_id else let s = String.concat "" (List.map (function | ArgArg s -> s - | ArgVar (_,id) -> string_of_id (interp_ident ist gl id)) l) in + | ArgVar (_,id) -> string_of_id (interp_ident ist env id)) l) in let s = if Lexer.is_keyword s then s^"0" else s in id_of_string s in - Tactics.fresh_id avoid id gl - -(* To retype a list of key*constr with undefined key *) -let retype_list sigma env lst = - List.fold_right (fun (x,csr) a -> - try (x,Retyping.get_judgment_of env sigma csr)::a with - | Anomaly _ -> a) lst [] + Tactics.fresh_id_in_env avoid id env -let extract_ltac_vars_data ist sigma env = - let (ltacvars,_ as vars) = constr_list ist env in - vars, retype_list sigma env ltacvars - -let extract_ltac_vars ist sigma env = - let (_,unbndltacvars),typs = extract_ltac_vars_data ist sigma env in - typs,unbndltacvars +let pf_interp_fresh_id ist gl = interp_fresh_id ist (pf_env gl) let implicit_tactic = ref None @@ -1416,11 +1280,11 @@ let declare_implicit_tactic tac = implicit_tactic := Some tac open Evd -let solvable_by_tactic env evi (ev,args) src = +let solvable_by_tactic env evi (ev,args) src = match (!implicit_tactic, src) with | Some tac, (ImplicitArg _ | QuestionMark _) - when - Environ.named_context_of_val evi.evar_hyps = + when + Environ.named_context_of_val evi.evar_hyps = Environ.named_context env -> let id = id_of_string "H" in start_proof id (Local,Proof Lemma) evi.evar_hyps evi.evar_concl @@ -1428,35 +1292,42 @@ let solvable_by_tactic env evi (ev,args) src = begin try by (tclCOMPLETE tac); - let _,(const,_,_,_) = cook_proof ignore in + let _,(const,_,_,_) = cook_proof ignore in delete_current_proof (); const.const_entry_body - with e when Logic.catchable_exception e -> + with e when Logic.catchable_exception e -> delete_current_proof(); raise Exit end | _ -> raise Exit -let solve_remaining_evars env initial_sigma evd c = - let evdref = ref (Typeclasses.resolve_typeclasses ~fail:true env evd) in +let solve_remaining_evars fail_evar use_classes env initial_sigma evd c = + let evdref = + if use_classes then ref (Typeclasses.resolve_typeclasses ~fail:true env evd) + else ref evd in let rec proc_rec c = - match kind_of_term (Reductionops.whd_evar (evars_of !evdref) c) with + let c = Reductionops.whd_evar !evdref c in + match kind_of_term c with | Evar (ev,args as k) when not (Evd.mem initial_sigma ev) -> let (loc,src) = evar_source ev !evdref in - let sigma = evars_of !evdref in + let sigma = !evdref in let evi = Evd.find sigma ev in - (try + (try let c = solvable_by_tactic env evi k src in - evdref := Evd.evar_define ev c !evdref; + evdref := Evd.define ev c !evdref; c with Exit -> - Pretype_errors.error_unsolvable_implicit loc env sigma evi src None) - | _ -> map_constr proc_rec c + if fail_evar then + Pretype_errors.error_unsolvable_implicit loc env sigma evi src None + else + c) + | _ -> map_constr proc_rec c in - proc_rec (Evarutil.nf_isevar !evdref c) + let c = proc_rec c in + (* Side-effect *) + !evdref,c -let interp_gen kind ist sigma env (c,ce) = - let (ltacvars,unbndltacvars as vars),typs = - extract_ltac_vars_data ist sigma env in +let interp_gen kind ist allow_patvar expand_evar fail_evar use_classes env sigma (c,ce) = + let (ltacvars,unbndltacvars as vars) = extract_ltac_constr_values ist env in let c = match ce with | None -> c (* If at toplevel (ce<>None), the error can be due to an incorrect @@ -1464,100 +1335,78 @@ let interp_gen kind ist sigma env (c,ce) = intros/lettac/inversion hypothesis names *) | Some c -> let ltacdata = (List.map fst ltacvars,unbndltacvars) in - intern_gen (kind = IsType) ~ltacvars:ltacdata sigma env c in - let trace = (dloc,LtacConstrInterp (c,vars))::ist.trace in - catch_error trace (understand_ltac sigma env (typs,unbndltacvars) kind) c + intern_gen (kind = IsType) ~allow_patvar ~ltacvars:ltacdata sigma env c + in + let trace = push_trace (dloc,LtacConstrInterp (c,vars)) ist.trace in + let evd,c = + catch_error trace (understand_ltac expand_evar sigma env vars kind) c in + let evd,c = + if expand_evar then + solve_remaining_evars fail_evar use_classes env sigma evd c + else + evd,c in + db_constr ist.debug env c; + (evd,c) -(* Interprets a constr and solve remaining evars with default tactic *) -let interp_econstr kind ist sigma env cc = - let evars,c = interp_gen kind ist sigma env cc in - let csr = solve_remaining_evars env sigma evars c in - db_constr ist.debug env csr; - csr +(* Interprets a constr; expects evars to be solved *) +let interp_constr_gen kind ist env sigma c = + snd (interp_gen kind ist false true true true env sigma c) -(* Interprets an open constr *) -let interp_open_constr ccl ist sigma env cc = - let evd,c = interp_gen (OfType ccl) ist sigma env cc in - (evars_of evd,c) +let interp_constr = interp_constr_gen (OfType None) + +let interp_type = interp_constr_gen IsType -let interp_open_type ccl ist sigma env cc = - let evd,c = interp_gen IsType ist sigma env cc in - (evars_of evd,c) +(* Interprets an open constr *) +let interp_open_constr_gen kind ist = + interp_gen kind ist false true false false -let interp_constr = interp_econstr (OfType None) +let interp_open_constr ccl = + interp_open_constr_gen (OfType ccl) -let interp_type = interp_econstr IsType +let interp_typed_pattern ist env sigma (c,_) = + let sigma, c = + interp_gen (OfType None) ist true false false false env sigma c in + pattern_of_constr sigma c (* Interprets a constr expression casted by the current goal *) -let pf_interp_casted_constr ist gl cc = - interp_econstr (OfType (Some (pf_concl gl))) ist (project gl) (pf_env gl) cc - -(* Interprets an open constr expression *) -let pf_interp_open_constr casted ist gl cc = - let cl = if casted then Some (pf_concl gl) else None in - interp_open_constr cl ist (project gl) (pf_env gl) cc +let pf_interp_casted_constr ist gl c = + interp_constr_gen (OfType (Some (pf_concl gl))) ist (pf_env gl) (project gl) c (* Interprets a constr expression *) let pf_interp_constr ist gl = - interp_constr ist (project gl) (pf_env gl) + interp_constr ist (pf_env gl) (project gl) let constr_list_of_VList env = function - | VList l -> List.map (constr_of_value env) l + | VList l -> List.map (closed_constr_of_value env) l | _ -> raise Not_found -let pf_interp_constr_in_compound_list inj_fun dest_fun interp_fun ist gl l = - let env = pf_env gl in - let try_expand_ltac_var x = +let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = + let try_expand_ltac_var sigma x = try match dest_fun x with - | RVar (_,id), _ -> - List.map inj_fun (constr_list_of_VList env (List.assoc id ist.lfun)) + | RVar (_,id), _ -> + sigma, + List.map inj_fun (constr_list_of_VList env (List.assoc id ist.lfun)) | _ -> - raise Not_found + raise Not_found with Not_found -> (*all of dest_fun, List.assoc, constr_list_of_VList may raise Not_found*) - [interp_fun ist gl x] in - List.flatten (List.map try_expand_ltac_var l) + let sigma, c = interp_fun ist env sigma x in + sigma, [c] in + let sigma, l = list_fold_map try_expand_ltac_var sigma l in + sigma, List.flatten l -let pf_interp_constr_list = - pf_interp_constr_in_compound_list (fun x -> x) (fun x -> x) - (fun ist gl -> interp_constr ist (project gl) (pf_env gl)) - -(* -let pf_interp_constr_list_as_list ist gl (c,_ as x) = - match c with - | RVar (_,id) -> - (try constr_list_of_VList (pf_env gl) (List.assoc id ist.lfun) - with Not_found -> []) - | _ -> [interp_constr ist (project gl) (pf_env gl) x] - -let pf_interp_constr_list ist gl l = - List.flatten (List.map (pf_interp_constr_list_as_list ist gl) l) -*) +let interp_constr_list ist env sigma c = + snd (interp_constr_in_compound_list (fun x -> x) (fun x -> x) (fun ist env sigma c -> (Evd.empty, interp_constr ist env sigma c)) ist env sigma c) let inj_open c = (Evd.empty,c) -let pf_interp_open_constr_list = - pf_interp_constr_in_compound_list inj_open (fun x -> x) - (fun ist gl -> interp_open_constr None ist (project gl) (pf_env gl)) - -(* -let pf_interp_open_constr_list_as_list ist gl (c,_ as x) = - match c with - | RVar (_,id) -> - (try List.map inj_open - (constr_list_of_VList (pf_env gl) (List.assoc id ist.lfun)) - with Not_found -> - [interp_open_constr None ist (project gl) (pf_env gl) x]) - | _ -> - [interp_open_constr None ist (project gl) (pf_env gl) x] - -let pf_interp_open_constr_list ist gl l = - List.flatten (List.map (pf_interp_open_constr_list_as_list ist gl) l) -*) +let interp_open_constr_list = + interp_constr_in_compound_list (fun x -> x) (fun x -> x) + (interp_open_constr None) (* Interprets a type expression *) let pf_interp_type ist gl = - interp_type ist (project gl) (pf_env gl) + interp_type ist (pf_env gl) (project gl) (* Interprets a reduction expression *) let interp_unfold ist env (occs,qid) = @@ -1566,28 +1415,34 @@ let interp_unfold ist env (occs,qid) = let interp_flag ist env red = { red with rConst = List.map (interp_evaluable ist env) red.rConst } -let interp_pattern ist sigma env (occs,c) = +let interp_constr_with_occurrences ist sigma env (occs,c) = (interp_occurrences ist occs, interp_constr ist sigma env c) -let pf_interp_constr_with_occurrences ist gl = - interp_pattern ist (project gl) (pf_env gl) +let interp_typed_pattern_with_occurrences ist env sigma (occs,c) = + let sign,p = interp_typed_pattern ist env sigma c in + sign, (interp_occurrences ist occs, p) -let pf_interp_constr_with_occurrences_and_name_as_list = - pf_interp_constr_in_compound_list +let interp_closed_typed_pattern_with_occurrences ist env sigma occl = + snd (interp_typed_pattern_with_occurrences ist env sigma occl) + +let interp_constr_with_occurrences_and_name_as_list = + interp_constr_in_compound_list (fun c -> ((all_occurrences_expr,c),Anonymous)) - (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c + (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c | _ -> raise Not_found) - (fun ist gl (occ_c,na) -> - (interp_pattern ist (project gl) (pf_env gl) occ_c, - interp_fresh_name ist gl na)) + (fun ist env sigma (occ_c,na) -> + sigma, (interp_constr_with_occurrences ist env sigma occ_c, + interp_fresh_name ist env na)) let interp_red_expr ist sigma env = function | Unfold l -> Unfold (List.map (interp_unfold ist env) l) - | Fold l -> Fold (List.map (interp_constr ist sigma env) l) + | Fold l -> Fold (List.map (interp_constr ist env sigma) l) | Cbv f -> Cbv (interp_flag ist env f) | Lazy f -> Lazy (interp_flag ist env f) - | Pattern l -> Pattern (List.map (interp_pattern ist sigma env) l) - | Simpl o -> Simpl (Option.map (interp_pattern ist sigma env) o) + | Pattern l -> + Pattern (List.map (interp_constr_with_occurrences ist env sigma) l) + | Simpl o -> + Simpl(Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r let pf_interp_red_expr ist gl = interp_red_expr ist (project gl) (pf_env gl) @@ -1606,17 +1461,17 @@ let interp_may_eval f ist gl = function user_err_loc (loc, "interp_may_eval", str "Unbound context identifier" ++ pr_id s ++ str".")) | ConstrTypeOf c -> pf_type_of gl (f ist gl c) - | ConstrTerm c -> - try + | ConstrTerm c -> + try f ist gl c with e -> debugging_exception_step ist false e (fun () -> str"interpretation of term " ++ pr_rawconstr_env (pf_env gl) (fst c)); - raise e + raise e (* Interprets a constr expression possibly to first evaluate *) let interp_constr_may_eval ist gl c = - let csr = + let csr = try interp_may_eval pf_interp_constr ist gl c with e -> @@ -1628,48 +1483,56 @@ let interp_constr_may_eval ist gl c = csr end -let inj_may_eval = function - | ConstrTerm c -> ConstrTerm (inj_open c) - | ConstrEval (r,c) -> ConstrEval (Tactics.inj_red_expr r,inj_open c) - | ConstrContext (id,c) -> ConstrContext (id,inj_open c) - | ConstrTypeOf c -> ConstrTypeOf (inj_open c) - -let message_of_value = function +let rec message_of_value gl = function | VVoid -> str "()" | VInteger n -> int n | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat) - | VConstr_context c | VConstr c -> pr_constr c + | VConstr_context c -> pr_constr_env (pf_env gl) c + | VConstr c -> pr_constr_under_binders_env (pf_env gl) c | VRec _ | VRTactic _ | VFun _ -> str "<tactic>" - | VList _ -> str "<list>" + | VList l -> prlist_with_sep spc (message_of_value gl) l -let rec interp_message_token ist = function +let rec interp_message_token ist gl = function | MsgString s -> str s | MsgInt n -> int n | MsgIdent (loc,id) -> let v = try List.assoc id ist.lfun with Not_found -> user_err_loc (loc,"",pr_id id ++ str" not found.") in - message_of_value v + message_of_value gl v -let rec interp_message_nl ist = function +let rec interp_message_nl ist gl = function | [] -> mt() - | l -> prlist_with_sep spc (interp_message_token ist) l ++ fnl() + | l -> prlist_with_sep spc (interp_message_token ist gl) l ++ fnl() -let interp_message ist l = - (* Force evaluation of interp_message_token so that potential errors +let interp_message ist gl l = + (* Force evaluation of interp_message_token so that potential errors are raised now and not at printing time *) - prlist (fun x -> spc () ++ x) (List.map (interp_message_token ist) l) + prlist (fun x -> spc () ++ x) (List.map (interp_message_token ist gl) l) + +let intro_pattern_list_of_Vlist loc env = function + | VList l -> List.map (fun a -> loc,coerce_to_intro_pattern env a) l + | _ -> raise Not_found let rec interp_intro_pattern ist gl = function | loc, IntroOrAndPattern l -> loc, IntroOrAndPattern (interp_or_and_intro_pattern ist gl l) | loc, IntroIdentifier id -> loc, interp_intro_pattern_var loc ist (pf_env gl) id - | loc, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _) + | loc, IntroFresh id -> + loc, IntroFresh (interp_fresh_ident ist (pf_env gl) id) + | loc, (IntroWildcard | IntroAnonymous | IntroRewrite _ | IntroForthcoming _) as x -> x and interp_or_and_intro_pattern ist gl = - List.map (List.map (interp_intro_pattern ist gl)) + List.map (interp_intro_pattern_list_as_list ist gl) + +and interp_intro_pattern_list_as_list ist gl = function + | [loc,IntroIdentifier id] as l -> + (try intro_pattern_list_of_Vlist loc (pf_env gl) (List.assoc id ist.lfun) + with Not_found | CannotCoerceTo _ -> + List.map (interp_intro_pattern ist gl) l) + | l -> List.map (interp_intro_pattern ist gl) l let interp_in_hyp_as ist gl (id,ipat) = (interp_hyp ist gl id,Option.map (interp_intro_pattern ist gl) ipat) @@ -1700,56 +1563,249 @@ let interp_binding_name ist = function (* (as in Inversion) *) let coerce_to_decl_or_quant_hyp env = function | VInteger n -> AnonHyp n - | v -> + | v -> try NamedHyp (coerce_to_hyp env v) - with CannotCoerceTo _ -> + with CannotCoerceTo _ -> raise (CannotCoerceTo "a declared or quantified hypothesis") let interp_declared_or_quantified_hypothesis ist gl = function | AnonHyp n -> AnonHyp n | NamedHyp id -> let env = pf_env gl in - try try_interp_ltac_var + try try_interp_ltac_var (coerce_to_decl_or_quant_hyp env) ist (Some env) (dloc,id) with Not_found -> NamedHyp id -let interp_binding ist gl (loc,b,c) = - (loc,interp_binding_name ist b,pf_interp_open_constr false ist gl c) - -let interp_bindings ist gl = function -| NoBindings -> NoBindings -| ImplicitBindings l -> ImplicitBindings (pf_interp_open_constr_list ist gl l) -| ExplicitBindings l -> ExplicitBindings (List.map (interp_binding ist gl) l) - -let interp_constr_with_bindings ist gl (c,bl) = - (pf_interp_constr ist gl c, interp_bindings ist gl bl) - -let interp_open_constr_with_bindings ist gl (c,bl) = - (pf_interp_open_constr false ist gl c, interp_bindings ist gl bl) - -let interp_induction_arg ist gl = function - | ElimOnConstr c -> ElimOnConstr (interp_constr_with_bindings ist gl c) - | ElimOnAnonHyp n as x -> x +let interp_binding ist env sigma (loc,b,c) = + let sigma, c = interp_open_constr None ist env sigma c in + sigma, (loc,interp_binding_name ist b,c) + +let interp_bindings ist env sigma = function +| NoBindings -> + sigma, NoBindings +| ImplicitBindings l -> + let sigma, l = interp_open_constr_list ist env sigma l in + sigma, ImplicitBindings l +| ExplicitBindings l -> + let sigma, l = list_fold_map (interp_binding ist env) sigma l in + sigma, ExplicitBindings l + +let interp_constr_with_bindings ist env sigma (c,bl) = + let sigma, bl = interp_bindings ist env sigma bl in + let sigma, c = interp_open_constr None ist env sigma c in + sigma, (c,bl) + +let interp_open_constr_with_bindings ist env sigma (c,bl) = + let sigma, bl = interp_bindings ist env sigma bl in + let sigma, c = interp_open_constr None ist env sigma c in + sigma, (c, bl) + +let loc_of_bindings = function +| NoBindings -> dummy_loc +| ImplicitBindings l -> loc_of_rawconstr (fst (list_last l)) +| ExplicitBindings l -> pi1 (list_last l) + +let interp_open_constr_with_bindings_loc ist env sigma ((c,_),bl as cb) = + let loc1 = loc_of_rawconstr c in + let loc2 = loc_of_bindings bl in + let loc = if loc2 = dummy_loc then loc1 else join_loc loc1 loc2 in + let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in + sigma, (loc,cb) + +let interp_induction_arg ist gl sigma arg = + let env = pf_env gl in + match arg with + | ElimOnConstr c -> + let sigma, c = interp_constr_with_bindings ist env sigma c in + sigma, ElimOnConstr c + | ElimOnAnonHyp n as x -> sigma, x | ElimOnIdent (loc,id) -> try - match List.assoc id ist.lfun with + sigma, + match List.assoc id ist.lfun with | VInteger n -> ElimOnAnonHyp n | VIntroPattern (IntroIdentifier id) -> ElimOnIdent (loc,id) - | VConstr c -> ElimOnConstr (c,NoBindings) + | VConstr ([],c) -> ElimOnConstr (c,NoBindings) | _ -> user_err_loc (loc,"", strbrk "Cannot coerce " ++ pr_id id ++ strbrk " neither to a quantified hypothesis nor to a term.") with Not_found -> (* Interactive mode *) - if Tactics.is_quantified_hypothesis id gl then ElimOnIdent (loc,id) - else ElimOnConstr - (pf_interp_constr ist gl (RVar (loc,id),Some (CRef (Ident (loc,id)))), - NoBindings) + if Tactics.is_quantified_hypothesis id gl then + sigma, ElimOnIdent (loc,id) + else + let c = interp_constr ist env sigma (RVar (loc,id),Some (CRef (Ident (loc,id)))) in + sigma, ElimOnConstr (c,NoBindings) + +(* Associates variables with values and gives the remaining variables and + values *) +let head_with_value (lvar,lval) = + let rec head_with_value_rec lacc = function + | ([],[]) -> (lacc,[],[]) + | (vr::tvr,ve::tve) -> + (match vr with + | None -> head_with_value_rec lacc (tvr,tve) + | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) + | (vr,[]) -> (lacc,vr,[]) + | ([],ve) -> (lacc,[],ve) + in + head_with_value_rec [] (lvar,lval) + +(* Gives a context couple if there is a context identifier *) +let give_context ctxt = function + | None -> [] + | Some id -> [id,VConstr_context ctxt] + +(* Reads a pattern by substituting vars of lfun *) +let use_types = false -let mk_constr_value ist gl c = VConstr (pf_interp_constr ist gl c) -let mk_hyp_value ist gl c = VConstr (mkVar (interp_hyp ist gl c)) +let eval_pattern lfun ist env sigma (_,pat as c) = + if use_types then + snd (interp_typed_pattern ist env sigma c) + else + instantiate_pattern sigma lfun pat + +let read_pattern lfun ist env sigma = function + | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c) + | Term c -> Term (eval_pattern lfun ist env sigma c) + +(* Reads the hypotheses of a Match Context rule *) +let cons_and_check_name id l = + if List.mem id l then + user_err_loc (dloc,"read_match_goal_hyps", + strbrk ("Hypothesis pattern-matching variable "^(string_of_id id)^ + " used twice in the same pattern.")) + else id::l + +let rec read_match_goal_hyps lfun ist env sigma lidh = function + | (Hyp ((loc,na) as locna,mp))::tl -> + let lidh' = name_fold cons_and_check_name na lidh in + Hyp (locna,read_pattern lfun ist env sigma mp):: + (read_match_goal_hyps lfun ist env sigma lidh' tl) + | (Def ((loc,na) as locna,mv,mp))::tl -> + let lidh' = name_fold cons_and_check_name na lidh in + Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp):: + (read_match_goal_hyps lfun ist env sigma lidh' tl) + | [] -> [] + +(* Reads the rules of a Match Context or a Match *) +let rec read_match_rule lfun ist env sigma = function + | (All tc)::tl -> (All tc)::(read_match_rule lfun ist env sigma tl) + | (Pat (rl,mp,tc))::tl -> + Pat (read_match_goal_hyps lfun ist env sigma [] rl, read_pattern lfun ist env sigma mp,tc) + :: read_match_rule lfun ist env sigma tl + | [] -> [] + +(* For Match Context and Match *) +exception Not_coherent_metas +exception Eval_fail of std_ppcmds + +let is_match_catchable = function + | PatternMatchingFailure | Eval_fail _ -> true + | e -> Logic.catchable_exception e + +let equal_instances gl (ctx',c') (ctx,c) = + (* How to compare instances? Do we want the terms to be convertible? + unifiable? Do we want the universe levels to be relevant? + (historically, conv_x is used) *) + ctx = ctx' & pf_conv_x gl c' c + +(* Verifies if the matched list is coherent with respect to lcm *) +(* While non-linear matching is modulo eq_constr in matches, merge of *) +(* different instances of the same metavars is here modulo conversion... *) +let verify_metas_coherence gl (ln1,lcm) (ln,lm) = + let rec aux = function + | (id,c as x)::tl -> + if List.for_all (fun (id',c') -> id'<>id or equal_instances gl c' c) lcm + then + x :: aux tl + else + raise Not_coherent_metas + | [] -> lcm in + (ln@ln1,aux lm) + +let adjust (l,lc) = (l,List.map (fun (id,c) -> (id,([],c))) lc) + +(* Tries to match one hypothesis pattern with a list of hypotheses *) +let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps = + let get_id_couple id = function + | Name idpat -> [idpat,VConstr ([],mkVar id)] + | Anonymous -> [] in + let match_pat lmatch hyp pat = + match pat with + | Term t -> + let lmeta = extended_matches t hyp in + (try + let lmeta = verify_metas_coherence gl lmatch lmeta in + ([],lmeta,(fun () -> raise PatternMatchingFailure)) + with + | Not_coherent_metas -> raise PatternMatchingFailure); + | Subterm (b,ic,t) -> + let rec match_next_pattern find_next () = + let (lmeta,ctxt,find_next') = find_next () in + try + let lmeta = verify_metas_coherence gl lmatch (adjust lmeta) in + (give_context ctxt ic,lmeta,match_next_pattern find_next') + with + | Not_coherent_metas -> match_next_pattern find_next' () in + match_next_pattern (fun () -> match_subterm_gen b t hyp) () in + let rec apply_one_mhyp_context_rec = function + | (id,b,hyp as hd)::tl -> + (match patv with + | None -> + let rec match_next_pattern find_next () = + try + let (ids, lmeta, find_next') = find_next () in + (get_id_couple id hypname@ids, lmeta, hd, + match_next_pattern find_next') + with + | PatternMatchingFailure -> apply_one_mhyp_context_rec tl in + match_next_pattern (fun () -> + let hyp = if b<>None then refresh_universes_strict hyp else hyp in + match_pat lmatch hyp pat) () + | Some patv -> + match b with + | Some body -> + let rec match_next_pattern_in_body next_in_body () = + try + let (ids,lmeta,next_in_body') = next_in_body() in + let rec match_next_pattern_in_typ next_in_typ () = + try + let (ids',lmeta',next_in_typ') = next_in_typ() in + (get_id_couple id hypname@ids@ids', lmeta', hd, + match_next_pattern_in_typ next_in_typ') + with + | PatternMatchingFailure -> + match_next_pattern_in_body next_in_body' () in + match_next_pattern_in_typ + (fun () -> + let hyp = refresh_universes_strict hyp in + match_pat lmeta hyp pat) () + with PatternMatchingFailure -> apply_one_mhyp_context_rec tl + in + match_next_pattern_in_body + (fun () -> match_pat lmatch body patv) () + | None -> apply_one_mhyp_context_rec tl) + | [] -> + db_hyp_pattern_failure ist.debug env (hypname,pat); + raise PatternMatchingFailure + in + apply_one_mhyp_context_rec lhyps + +(* misc *) + +let mk_constr_value ist gl c = VConstr ([],pf_interp_constr ist gl c) +let mk_hyp_value ist gl c = VConstr ([],mkVar (interp_hyp ist gl c)) let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c) +let pack_sigma (sigma,c) = {it=c;sigma=sigma} + +let extend_gl_hyps gl sign = + { gl with + it = { gl.it with + evar_hyps = + List.fold_right Environ.push_named_context_val sign gl.it.evar_hyps } } + (* Interprets an l-tac expression into a value *) let rec val_interp ist gl (tac:glob_tactic_expr) = @@ -1758,13 +1814,13 @@ let rec val_interp ist gl (tac:glob_tactic_expr) = | TacFun (it,body) -> VFun (ist.trace,ist.lfun,it,body) | TacLetIn (true,l,u) -> interp_letrec ist gl l u | TacLetIn (false,l,u) -> interp_letin ist gl l u - | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr + | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr | TacArg a -> interp_tacarg ist gl a (* Delayed evaluation *) | t -> VFun (ist.trace,ist.lfun,[],t) - in check_for_interrupt (); + in check_for_interrupt (); match ist.debug with | DebugOn lev -> debug_prompt lev gl tac (fun v -> value_interp {ist with debug=v}) @@ -1776,26 +1832,27 @@ and eval_tactic ist = function let box = ref None in abstract_tactic_box := box; let call = LtacAtomCall (t,box) in let tac = (* catch error in the interpretation *) - catch_error ((dloc,call)::ist.trace) (interp_atomic ist gl) t in + catch_error (push_trace(dloc,call)ist.trace) + (interp_atomic ist gl) t in (* catch error in the evaluation *) - catch_error ((loc,call)::ist.trace) tac gl + catch_error (push_trace(loc,call)ist.trace) tac gl | TacFun _ | TacLetIn _ -> assert false | TacMatchGoal _ | TacMatch _ -> assert false - | TacId s -> tclIDTAC_MESSAGE (interp_message_nl ist s) - | TacFail (n,s) -> tclFAIL (interp_int_or_var ist n) (interp_message ist s) + | TacId s -> fun gl -> tclIDTAC_MESSAGE (interp_message_nl ist gl s) gl + | TacFail (n,s) -> fun gl -> tclFAIL (interp_int_or_var ist n) (interp_message ist gl s) gl | TacProgress tac -> tclPROGRESS (interp_tactic ist tac) | TacAbstract (tac,ido) -> fun gl -> Tactics.tclABSTRACT - (Option.map (interp_ident ist gl) ido) (interp_tactic ist tac) gl - | TacThen (t1,tf,t,tl) -> + (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) gl + | TacThen (t1,tf,t,tl) -> tclTHENS3PARTS (interp_tactic ist t1) (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) | TacThens (t1,tl) -> tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl) | TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac) | TacTry tac -> tclTRY (interp_tactic ist tac) - | TacInfo tac -> + | TacInfo tac -> let t = (interp_tactic ist tac) in - tclINFO + tclINFO begin match tac with TacAtom (_,_) -> t @@ -1807,7 +1864,7 @@ and eval_tactic ist = function | TacFirst l -> tclFIRST (List.map (interp_tactic ist) l) | TacSolve l -> tclSOLVE (List.map (interp_tactic ist) l) | TacComplete tac -> tclCOMPLETE (interp_tactic ist tac) - | TacArg a -> assert false + | TacArg a -> interp_tactic ist (TacArg a) and force_vrec ist gl = function | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} gl body @@ -1822,9 +1879,9 @@ and interp_ltac_reference loc' mustbetac ist gl = function | ArgArg (loc,r) -> let ids = extract_ids [] ist.lfun in let loc_info = ((if loc' = dloc then loc else loc'),LtacNameCall r) in - let ist = + let ist = { lfun=[]; debug=ist.debug; avoid_ids=ids; - trace = loc_info::ist.trace } in + trace = push_trace loc_info ist.trace } in val_interp ist gl (lookup r) and interp_tacarg ist gl = function @@ -1832,7 +1889,7 @@ and interp_tacarg ist gl = function | Reference r -> interp_ltac_reference dloc false ist gl r | Integer n -> VInteger n | IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat)) - | ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c) + | ConstrMayEval c -> VConstr ([],interp_constr_may_eval ist gl c) | MetaIdArg (loc,_,id) -> assert false | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist gl r | TacCall (loc,f,l) -> @@ -1842,18 +1899,18 @@ and interp_tacarg ist gl = function interp_app loc ist gl fv largs | TacExternal (loc,com,req,la) -> interp_external loc ist gl com req (List.map (interp_tacarg ist gl) la) - | TacFreshId l -> - let id = interp_fresh_id ist gl l in + | TacFreshId l -> + let id = pf_interp_fresh_id ist gl l in VIntroPattern (IntroIdentifier id) | Tacexp t -> val_interp ist gl t | TacDynamic(_,t) -> - let tg = (tag t) in + let tg = (Dyn.tag t) in if tg = "tactic" then val_interp ist gl (tactic_out t ist) else if tg = "value" then value_out t else if tg = "constr" then - VConstr (constr_out t) + VConstr ([],constr_out t) else anomaly_loc (dloc, "Tacinterp.val_interp", (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">")) @@ -1861,21 +1918,28 @@ and interp_tacarg ist gl = function (* Interprets an application node *) and interp_app loc ist gl fv largs = match fv with - | VFun(trace,olfun,var,body) -> - let (newlfun,lvar,lval)=head_with_value (var,largs) in - if lvar=[] then - let v = - try - catch_error trace - (val_interp { ist with lfun=newlfun@olfun; trace=trace } gl) body - with e -> - debugging_exception_step ist false e (fun () -> str "evaluation"); - raise e in - debugging_step ist (fun () -> - str "evaluation returns" ++ fnl() ++ pr_value (Some (pf_env gl)) v); - if lval=[] then v else interp_app loc ist gl v lval - else - VFun(trace,newlfun@olfun,lvar,body) + (* if var=[] and body has been delayed by val_interp, then body + is not a tactic that expects arguments. + Otherwise Ltac goes into an infinite loop (val_interp puts + a VFun back on body, and then interp_app is called again...) *) + | (VFun(trace,olfun,(_::_ as var),body) + |VFun(trace,olfun,([] as var), + (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> + let (newlfun,lvar,lval)=head_with_value (var,largs) in + if lvar=[] then + let v = + try + catch_error trace + (val_interp {ist with lfun=newlfun@olfun; trace=trace} gl) body + with e -> + debugging_exception_step ist false e (fun () -> str "evaluation"); + raise e in + debugging_step ist + (fun () -> + str"evaluation returns"++fnl()++pr_value (Some (pf_env gl)) v); + if lval=[] then v else interp_app loc ist gl v lval + else + VFun(trace,newlfun@olfun,lvar,body) | _ -> user_err_loc (loc, "Tacinterp.interp_app", (str"Illegal tactic application.")) @@ -1887,8 +1951,13 @@ and tactic_of_value ist vle g = | VFun (trace,lfun,[],t) -> let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in catch_error trace tac g - | VFun _ -> error "A fully applied tactic is expected." - | _ -> raise NotTactic + | (VFun _|VRec _) -> error "A fully applied tactic is expected." + | VConstr _ -> errorlabstrm "" (str"Value is a term. Expected a tactic.") + | VConstr_context _ -> + errorlabstrm "" (str"Value is a term context. Expected a tactic.") + | VIntroPattern _ -> + errorlabstrm "" (str"Value is an intro pattern. Expected a tactic.") + | _ -> errorlabstrm "" (str"Expression does not evaluate to a tactic.") (* Evaluation with FailError catching *) and eval_with_fail ist is_lazy goal tac = @@ -1899,9 +1968,9 @@ and eval_with_fail ist is_lazy goal tac = VRTactic (catch_error trace tac goal) | a -> a) with - | FailError (0,s) | Stdpp.Exc_located(_, FailError (0,s)) + | FailError (0,s) | Stdpp.Exc_located(_, FailError (0,s)) | Stdpp.Exc_located(_,LtacLocated (_,FailError (0,s))) -> - raise (Eval_fail s) + raise (Eval_fail (Lazy.force s)) | FailError (lvl,s) -> raise (FailError (lvl - 1, s)) | Stdpp.Exc_located(s,FailError (lvl,s')) -> raise (Stdpp.Exc_located(s,FailError (lvl - 1, s'))) @@ -1933,10 +2002,10 @@ and interp_match_goal ist goal lz lr lmr = let rec match_next_pattern find_next () = let (lgoal,ctxt,find_next') = find_next () in let lctxt = give_context ctxt id in - try apply_hyps_context ist env lz goal mt lctxt lgoal mhyps hyps + try apply_hyps_context ist env lz goal mt lctxt (adjust lgoal) mhyps hyps with e when is_match_catchable e -> match_next_pattern find_next' () in match_next_pattern (fun () -> match_subterm_gen app c csr) () in - let rec apply_match_goal ist env goal nrs lex lpt = + let rec apply_match_goal ist env goal nrs lex lpt = begin if lex<>[] then db_pattern_rule ist.debug nrs (List.hd lex); match lpt with @@ -1974,7 +2043,8 @@ and interp_match_goal ist goal lz lr lmr = else mt()) ++ str".")) end in apply_match_goal ist env goal 0 lmr - (read_match_rule (fst (constr_list ist env)) lmr) + (read_match_rule (fst (extract_ltac_constr_values ist env)) + ist env (project goal) lmr) (* Tries to match the hypotheses in a Match Context *) and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps = @@ -1992,7 +2062,7 @@ and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps = let id_match = pi1 hyp_match in let nextlhyps = list_remove_assoc_in_triple id_match lhyps_rest in apply_hyps_context_rec (lfun@lids) lm nextlhyps tl - with e when is_match_catchable e -> + with e when is_match_catchable e -> match_next_pattern find_next' in let init_match_pattern () = apply_one_mhyp_context ist env goal lmatch hyp_pat lhyps_rest in @@ -2026,15 +2096,15 @@ and interp_genarg ist gl x = (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)) | IdentArgType b -> in_gen (wit_ident_gen b) - (interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x)) + (pf_interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x)) | VarArgType -> in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x)) | RefArgType -> in_gen wit_ref (pf_interp_reference ist gl (out_gen globwit_ref x)) | SortArgType -> in_gen wit_sort - (destSort - (pf_interp_constr ist gl + (destSort + (pf_interp_constr ist gl (RSort (dloc,out_gen globwit_sort x), None))) | ConstrArgType -> in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x)) @@ -2047,15 +2117,17 @@ and interp_genarg ist gl x = | RedExprArgType -> in_gen wit_red_expr (pf_interp_red_expr ist gl (out_gen globwit_red_expr x)) | OpenConstrArgType casted -> - in_gen (wit_open_constr_gen casted) - (pf_interp_open_constr casted ist gl + in_gen (wit_open_constr_gen casted) + (interp_open_constr (if casted then Some (pf_concl gl) else None) + ist (pf_env gl) (project gl) (snd (out_gen (globwit_open_constr_gen casted) x))) | ConstrWithBindingsArgType -> in_gen wit_constr_with_bindings - (interp_constr_with_bindings ist gl (out_gen globwit_constr_with_bindings x)) + (pack_sigma (interp_constr_with_bindings ist (pf_env gl) (project gl) + (out_gen globwit_constr_with_bindings x))) | BindingsArgType -> in_gen wit_bindings - (interp_bindings ist gl (out_gen globwit_bindings x)) + (pack_sigma (interp_bindings ist (pf_env gl) (project gl) (out_gen globwit_bindings x))) | List0ArgType ConstrArgType -> interp_genarg_constr_list0 ist gl x | List1ArgType ConstrArgType -> interp_genarg_constr_list1 ist gl x | List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x @@ -2064,22 +2136,24 @@ and interp_genarg ist gl x = | List1ArgType _ -> app_list1 (interp_genarg ist gl) x | OptArgType _ -> app_opt (interp_genarg ist gl) x | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x - | ExtraArgType s -> + | ExtraArgType s -> match tactic_genarg_level s with - | Some n -> + | Some n -> (* Special treatment of tactic arguments *) - in_gen (wit_tactic n) (out_gen (globwit_tactic n) x) - | None -> + in_gen (wit_tactic n) + (TacArg(valueIn(VFun(ist.trace,ist.lfun,[], + out_gen (globwit_tactic n) x)))) + | None -> lookup_interp_genarg s ist gl x and interp_genarg_constr_list0 ist gl x = let lc = out_gen (wit_list0 globwit_constr) x in - let lc = pf_interp_constr_list ist gl lc in + let lc = pf_apply (interp_constr_list ist) gl lc in in_gen (wit_list0 wit_constr) lc and interp_genarg_constr_list1 ist gl x = let lc = out_gen (wit_list1 globwit_constr) x in - let lc = pf_interp_constr_list ist gl lc in + let lc = pf_apply (interp_constr_list ist) gl lc in in_gen (wit_list1 wit_constr) lc and interp_genarg_var_list0 ist gl x = @@ -2098,7 +2172,7 @@ and interp_match ist g lz constr lmr = let rec match_next_pattern find_next () = let (lmatch,ctxt,find_next') = find_next () in let lctxt = give_context ctxt id in - let lfun = extend_values_with_bindings lmatch (lctxt@ist.lfun) in + let lfun = extend_values_with_bindings (adjust lmatch) (lctxt@ist.lfun) in try eval_with_fail {ist with lfun=lfun} lz g mt with e when is_match_catchable e -> match_next_pattern find_next' () in @@ -2109,7 +2183,7 @@ and interp_match ist g lz constr lmr = with e when is_match_catchable e -> apply_match ist csr []) | (Pat ([],Term c,mt))::tl -> (try - let lmatch = + let lmatch = try extended_matches c csr with e -> debugging_exception_step ist false e (fun () -> @@ -2134,14 +2208,14 @@ and interp_match ist g lz constr lmr = | _ -> errorlabstrm "Tacinterp.apply_match" (str "No matching clauses for match.") in - let csr = + let csr = try interp_ltac_constr ist g constr with e -> debugging_exception_step ist true e (fun () -> str "evaluation of the matched expression"); raise e in - let ilr = read_match_rule (fst (constr_list ist (pf_env g))) lmr in - let res = - try apply_match ist csr ilr with e -> + let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) (project g) lmr in + let res = + try apply_match ist csr ilr with e -> debugging_exception_step ist true e (fun () -> str "match expression"); raise e in debugging_step ist (fun () -> @@ -2150,8 +2224,8 @@ and interp_match ist g lz constr lmr = (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist gl e = - let result = - try val_interp ist gl e with Not_found -> + let result = + try val_interp ist gl e with Not_found -> debugging_step ist (fun () -> str "evaluation failed for" ++ fnl() ++ Pptactic.pr_glob_tactic (pf_env gl) e); @@ -2160,11 +2234,13 @@ and interp_ltac_constr ist gl e = let cresult = constr_of_value (pf_env gl) result in debugging_step ist (fun () -> Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++ - str " has value " ++ fnl() ++ print_constr_env (pf_env gl) cresult); - cresult + str " has value " ++ fnl() ++ + pr_constr_under_binders_env (pf_env gl) cresult); + if fst cresult <> [] then raise Not_found; + snd cresult with Not_found -> errorlabstrm "" - (str "Must evaluate to a term" ++ fnl() ++ + (str "Must evaluate to a closed term" ++ fnl() ++ str "offending expression: " ++ fnl() ++ Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++ str "this is a " ++ (match result with @@ -2173,7 +2249,7 @@ and interp_ltac_constr ist gl e = (str "VFun with body " ++ fnl() ++ Pptactic.pr_glob_tactic (pf_env gl) b ++ fnl() ++ str "instantiated arguments " ++ fnl() ++ - List.fold_right + List.fold_right (fun p s -> let (i,v) = p in str (string_of_id i) ++ str ", " ++ s) il (str "") ++ @@ -2194,63 +2270,71 @@ and interp_ltac_constr ist gl e = (* Interprets tactic expressions : returns a "tactic" *) and interp_tactic ist tac gl = - try tactic_of_value ist (val_interp ist gl tac) gl - with NotTactic -> errorlabstrm "" (str "Not a tactic.") + tactic_of_value ist (val_interp ist gl tac) gl (* Interprets a primitive tactic *) -and interp_atomic ist gl = function +and interp_atomic ist gl tac = + let env = pf_env gl and sigma = project gl in + match tac with (* Basic tactics *) | TacIntroPattern l -> - h_intro_patterns (List.map (interp_intro_pattern ist gl) l) + h_intro_patterns (interp_intro_pattern_list_as_list ist gl l) | TacIntrosUntil hyp -> h_intros_until (interp_quantified_hypothesis ist hyp) | TacIntroMove (ido,hto) -> - h_intro_move (Option.map (interp_fresh_ident ist gl) ido) + h_intro_move (Option.map (interp_fresh_ident ist env) ido) (interp_move_location ist gl hto) | TacAssumption -> h_assumption | TacExact c -> h_exact (pf_interp_casted_constr ist gl c) | TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c) | TacVmCastNoCheck c -> h_vm_cast_no_check (pf_interp_constr ist gl c) - | TacApply (a,ev,cb,None) -> - h_apply a ev (List.map (interp_open_constr_with_bindings ist gl) cb) - | TacApply (a,ev,cb,Some cl) -> - h_apply_in a ev (List.map (interp_open_constr_with_bindings ist gl) cb) - (interp_in_hyp_as ist gl cl) + | TacApply (a,ev,cb,cl) -> + let sigma, l = + list_fold_map (interp_open_constr_with_bindings_loc ist env) sigma cb + in + let tac = match cl with + | None -> h_apply a ev + | Some cl -> + (fun l -> h_apply_in a ev l (interp_in_hyp_as ist gl cl)) in + tclWITHHOLES ev tac sigma l | TacElim (ev,cb,cbo) -> - h_elim ev (interp_constr_with_bindings ist gl cb) - (Option.map (interp_constr_with_bindings ist gl) cbo) + let sigma, cb = interp_constr_with_bindings ist env sigma cb in + let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in + tclWITHHOLES ev (h_elim ev cb) sigma cbo | TacElimType c -> h_elim_type (pf_interp_type ist gl c) - | TacCase (ev,cb) -> h_case ev (interp_constr_with_bindings ist gl cb) + | TacCase (ev,cb) -> + let sigma, cb = interp_constr_with_bindings ist env sigma cb in + tclWITHHOLES ev (h_case ev) sigma cb | TacCaseType c -> h_case_type (pf_interp_type ist gl c) - | TacFix (idopt,n) -> h_fix (Option.map (interp_fresh_ident ist gl) idopt) n + | TacFix (idopt,n) -> h_fix (Option.map (interp_fresh_ident ist env) idopt) n | TacMutualFix (b,id,n,l) -> - let f (id,n,c) = (interp_fresh_ident ist gl id,n,pf_interp_type ist gl c) - in h_mutual_fix b (interp_fresh_ident ist gl id) n (List.map f l) - | TacCofix idopt -> h_cofix (Option.map (interp_fresh_ident ist gl) idopt) + let f (id,n,c) = (interp_fresh_ident ist env id,n,pf_interp_type ist gl c) + in h_mutual_fix b (interp_fresh_ident ist env id) n (List.map f l) + | TacCofix idopt -> h_cofix (Option.map (interp_fresh_ident ist env) idopt) | TacMutualCofix (b,id,l) -> - let f (id,c) = (interp_fresh_ident ist gl id,pf_interp_type ist gl c) in - h_mutual_cofix b (interp_fresh_ident ist gl id) (List.map f l) + let f (id,c) = (interp_fresh_ident ist env id,pf_interp_type ist gl c) in + h_mutual_cofix b (interp_fresh_ident ist env id) (List.map f l) | TacCut c -> h_cut (pf_interp_type ist gl c) | TacAssert (t,ipat,c) -> - let c = (if t=None then interp_constr else interp_type) ist (project gl) (pf_env gl) c in - abstract_tactic (TacAssert (t,ipat,inj_open c)) + let c = (if t=None then interp_constr else interp_type) ist env sigma c in + abstract_tactic (TacAssert (t,ipat,c)) (Tactics.forward (Option.map (interp_tactic ist) t) (Option.map (interp_intro_pattern ist gl) ipat) c) | TacGeneralize cl -> - h_generalize_gen - (pf_interp_constr_with_occurrences_and_name_as_list ist gl cl) + let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in + tclWITHHOLES false (h_generalize_gen) sigma cl | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c) | TacLetTac (na,c,clp,b) -> let clp = interp_clause ist gl clp in - h_let_tac b (interp_fresh_name ist gl na) (pf_interp_constr ist gl c) clp + h_let_tac b (interp_fresh_name ist env na) (pf_interp_constr ist gl c) clp (* Automation tactics *) - | TacTrivial (lems,l) -> - Auto.h_trivial (pf_interp_constr_list ist gl lems) + | TacTrivial (lems,l) -> + Auto.h_trivial (interp_constr_list ist env sigma lems) (Option.map (List.map (interp_hint_base ist)) l) | TacAuto (n,lems,l) -> Auto.h_auto (Option.map (interp_int_or_var ist) n) - (pf_interp_constr_list ist gl lems) + (interp_constr_list ist env sigma lems) (Option.map (List.map (interp_hint_base ist)) l) | TacAutoTDB n -> Dhyp.h_auto_tdb n | TacDestructHyp (b,id) -> Dhyp.h_destructHyp b (interp_hyp ist gl id) @@ -2258,19 +2342,23 @@ and interp_atomic ist gl = function | TacSuperAuto (n,l,b1,b2) -> Auto.h_superauto n l b1 b2 | TacDAuto (n,p,lems) -> Auto.h_dauto (Option.map (interp_int_or_var ist) n,p) - (pf_interp_constr_list ist gl lems) + (interp_constr_list ist env sigma lems) (* Derived basic tactics *) | TacSimpleInductionDestruct (isrec,h) -> h_simple_induction_destruct isrec (interp_quantified_hypothesis ist h) - | TacInductionDestruct (isrec,ev,l) -> - h_induction_destruct ev isrec - (List.map (fun (lc,cbo,(ipato,ipats),cls) -> - (List.map (interp_induction_arg ist gl) lc, - Option.map (interp_constr_with_bindings ist gl) cbo, - (Option.map (interp_intro_pattern ist gl) ipato, - Option.map (interp_intro_pattern ist gl) ipats), - Option.map (interp_clause ist gl) cls)) l) + | TacInductionDestruct (isrec,ev,(l,cls)) -> + let sigma, l = + list_fold_map (fun sigma (lc,cbo,(ipato,ipats)) -> + let sigma,lc = + list_fold_map (interp_induction_arg ist gl) sigma lc in + let sigma,cbo = + Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in + (sigma,(lc,cbo, + (Option.map (interp_intro_pattern ist gl) ipato, + Option.map (interp_intro_pattern ist gl) ipats)))) sigma l in + let cls = Option.map (interp_clause ist gl) cls in + tclWITHHOLES ev (h_induction_destruct isrec ev) sigma (l,cls) | TacDoubleInduction (h1,h2) -> let h1 = interp_quantified_hypothesis ist h1 in let h2 = interp_quantified_hypothesis ist h2 in @@ -2280,8 +2368,9 @@ and interp_atomic ist gl = function | TacDecompose (l,c) -> let l = List.map (interp_inductive ist) l in Elim.h_decompose l (pf_interp_constr ist gl c) - | TacSpecialize (n,l) -> - h_specialize n (interp_constr_with_bindings ist gl l) + | TacSpecialize (n,cb) -> + let sigma, cb = interp_constr_with_bindings ist env sigma cb in + tclWITHHOLES false (h_specialize n) sigma cb | TacLApply c -> h_lapply (pf_interp_constr ist gl c) (* Context management *) @@ -2290,50 +2379,64 @@ and interp_atomic ist gl = function | TacMove (dep,id1,id2) -> h_move dep (interp_hyp ist gl id1) (interp_move_location ist gl id2) | TacRename l -> - h_rename (List.map (fun (id1,id2) -> - interp_hyp ist gl id1, - interp_fresh_ident ist gl (snd id2)) l) + h_rename (List.map (fun (id1,id2) -> + interp_hyp ist gl id1, + interp_fresh_ident ist env (snd id2)) l) | TacRevert l -> h_revert (interp_hyp_list ist gl l) (* Constructors *) - | TacLeft (ev,bl) -> h_left ev (interp_bindings ist gl bl) - | TacRight (ev,bl) -> h_right ev (interp_bindings ist gl bl) - | TacSplit (ev,_,bl) -> h_split ev (interp_bindings ist gl bl) + | TacLeft (ev,bl) -> + let sigma, bl = interp_bindings ist env sigma bl in + tclWITHHOLES ev (h_left ev) sigma bl + | TacRight (ev,bl) -> + let sigma, bl = interp_bindings ist env sigma bl in + tclWITHHOLES ev (h_right ev) sigma bl + | TacSplit (ev,_,bll) -> + let sigma, bll = list_fold_map (interp_bindings ist env) sigma bll in + tclWITHHOLES ev (h_split ev) sigma bll | TacAnyConstructor (ev,t) -> abstract_tactic (TacAnyConstructor (ev,t)) (Tactics.any_constructor ev (Option.map (interp_tactic ist) t)) | TacConstructor (ev,n,bl) -> - h_constructor ev (skip_metaid n) (interp_bindings ist gl bl) + let sigma, bl = interp_bindings ist env sigma bl in + tclWITHHOLES ev (h_constructor ev (skip_metaid n)) sigma bl (* Conversion *) | TacReduce (r,cl) -> h_reduce (pf_interp_red_expr ist gl r) (interp_clause ist gl cl) - | TacChange (occl,c,cl) -> - h_change (Option.map (pf_interp_constr_with_occurrences ist gl) occl) - (if occl = None & (cl.onhyps = None or cl.onhyps = Some []) & + | TacChange (None,c,cl) -> + h_change None + (if (cl.onhyps = None or cl.onhyps = Some []) & (cl.concl_occs = all_occurrences_expr or cl.concl_occs = no_occurrences_expr) - then pf_interp_type ist gl c + then pf_interp_type ist gl c else pf_interp_constr ist gl c) (interp_clause ist gl cl) + | TacChange (Some op,c,cl) -> + let sign,op = interp_typed_pattern ist env sigma op in + h_change (Some op) + (pf_interp_constr ist (extend_gl_hyps gl sign) c) + (interp_clause ist gl cl) (* Equivalence relations *) | TacReflexivity -> h_reflexivity | TacSymmetry c -> h_symmetry (interp_clause ist gl c) - | TacTransitivity c -> h_transitivity (pf_interp_constr ist gl c) + | TacTransitivity c -> h_transitivity (Option.map (pf_interp_constr ist gl) c) (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - Equality.general_multi_multi_rewrite ev - (List.map (fun (b,m,c) -> (b,m,interp_open_constr_with_bindings ist gl c)) l) - (interp_clause ist gl cl) - (Option.map (interp_tactic ist) by) + | TacRewrite (ev,l,cl,by) -> + let l = List.map (fun (b,m,c) -> + let f env sigma = interp_open_constr_with_bindings ist env sigma c in + (b,m,f)) l in + let cl = interp_clause ist gl cl in + Equality.general_multi_multi_rewrite ev l cl + (Option.map (fun by -> tclCOMPLETE (interp_tactic ist by), Equality.Naive) by) | TacInversion (DepInversion (k,c,ids),hyp) -> Inv.dinv k (Option.map (pf_interp_constr ist gl) c) (Option.map (interp_intro_pattern ist gl) ids) (interp_declared_or_quantified_hypothesis ist gl hyp) | TacInversion (NonDepInversion (k,idl,ids),hyp) -> - Inv.inv_clause k + Inv.inv_clause k (Option.map (interp_intro_pattern ist gl) ids) (interp_hyp_list ist gl idl) (interp_declared_or_quantified_hypothesis ist gl hyp) @@ -2349,79 +2452,94 @@ and interp_atomic ist gl = function abstract_extended_tactic opn args (tac args) | TacAlias (loc,s,l,(_,body)) -> fun gl -> let rec f x = match genarg_tag x with - | IntArgType -> + | IntArgType -> VInteger (out_gen globwit_int x) | IntOrVarArgType -> mk_int_or_var_value ist (out_gen globwit_int_or_var x) | PreIdentArgType -> failwith "pre-identifiers cannot be bound" | IntroPatternArgType -> - VIntroPattern + VIntroPattern (snd (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))) | IdentArgType b -> - VIntroPattern - (IntroIdentifier - (interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x))) + value_of_ident (interp_fresh_ident ist env + (out_gen (globwit_ident_gen b) x)) | VarArgType -> mk_hyp_value ist gl (out_gen globwit_var x) - | RefArgType -> - VConstr (constr_of_global + | RefArgType -> + VConstr ([],constr_of_global (pf_interp_reference ist gl (out_gen globwit_ref x))) - | SortArgType -> - VConstr (mkSort (interp_sort (out_gen globwit_sort x))) + | SortArgType -> + VConstr ([],mkSort (interp_sort (out_gen globwit_sort x))) | ConstrArgType -> mk_constr_value ist gl (out_gen globwit_constr x) | ConstrMayEvalArgType -> VConstr - (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x)) + ([],interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x)) | ExtraArgType s when tactic_genarg_level s <> None -> (* Special treatment of tactic arguments *) - val_interp ist gl + val_interp ist gl (out_gen (globwit_tactic (Option.get (tactic_genarg_level s))) x) - | List0ArgType ConstrArgType -> + | List0ArgType ConstrArgType -> let wit = wit_list0 globwit_constr in VList (List.map (mk_constr_value ist gl) (out_gen wit x)) - | List0ArgType VarArgType -> + | List0ArgType VarArgType -> let wit = wit_list0 globwit_var in VList (List.map (mk_hyp_value ist gl) (out_gen wit x)) - | List0ArgType IntArgType -> + | List0ArgType IntArgType -> let wit = wit_list0 globwit_int in VList (List.map (fun x -> VInteger x) (out_gen wit x)) - | List0ArgType IntOrVarArgType -> + | List0ArgType IntOrVarArgType -> let wit = wit_list0 globwit_int_or_var in VList (List.map (mk_int_or_var_value ist) (out_gen wit x)) - | List1ArgType ConstrArgType -> + | List0ArgType (IdentArgType b) -> + let wit = wit_list0 (globwit_ident_gen b) in + let mk_ident x = value_of_ident (interp_fresh_ident ist env x) in + VList (List.map mk_ident (out_gen wit x)) + | List0ArgType IntroPatternArgType -> + let wit = wit_list0 globwit_intro_pattern in + let mk_ipat x = VIntroPattern (snd (interp_intro_pattern ist gl x)) in + VList (List.map mk_ipat (out_gen wit x)) + | List1ArgType ConstrArgType -> let wit = wit_list1 globwit_constr in VList (List.map (mk_constr_value ist gl) (out_gen wit x)) - | List1ArgType VarArgType -> + | List1ArgType VarArgType -> let wit = wit_list1 globwit_var in VList (List.map (mk_hyp_value ist gl) (out_gen wit x)) - | List1ArgType IntArgType -> + | List1ArgType IntArgType -> let wit = wit_list1 globwit_int in VList (List.map (fun x -> VInteger x) (out_gen wit x)) - | List1ArgType IntOrVarArgType -> + | List1ArgType IntOrVarArgType -> let wit = wit_list1 globwit_int_or_var in VList (List.map (mk_int_or_var_value ist) (out_gen wit x)) + | List1ArgType (IdentArgType b) -> + let wit = wit_list1 (globwit_ident_gen b) in + let mk_ident x = value_of_ident (interp_fresh_ident ist env x) in + VList (List.map mk_ident (out_gen wit x)) + | List1ArgType IntroPatternArgType -> + let wit = wit_list1 globwit_intro_pattern in + let mk_ipat x = VIntroPattern (snd (interp_intro_pattern ist gl x)) in + VList (List.map mk_ipat (out_gen wit x)) | StringArgType | BoolArgType - | QuantHypArgType | RedExprArgType - | OpenConstrArgType _ | ConstrWithBindingsArgType - | ExtraArgType _ | BindingsArgType - | OptArgType _ | PairArgType _ - | List0ArgType _ | List1ArgType _ + | QuantHypArgType | RedExprArgType + | OpenConstrArgType _ | ConstrWithBindingsArgType + | ExtraArgType _ | BindingsArgType + | OptArgType _ | PairArgType _ + | List0ArgType _ | List1ArgType _ -> error "This generic type is not supported in alias." - + in let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in - let trace = (loc,LtacNotationCall s)::ist.trace in + let trace = push_trace (loc,LtacNotationCall s) ist.trace in interp_tactic { ist with lfun=lfun; trace=trace } body gl let make_empty_glob_sign () = - { ltacvars = ([],[]); ltacrecvars = []; + { ltacvars = ([],[]); ltacrecvars = []; gsigma = Evd.empty; genv = Global.env() } (* Initial call for interpretation *) -let interp_tac_gen lfun avoid_ids debug t gl = - interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] } +let interp_tac_gen lfun avoid_ids debug t gl = + interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] } (intern_tactic { ltacvars = (List.map fst lfun, []); ltacrecvars = []; gsigma = project gl; genv = pf_env gl } t) gl @@ -2433,17 +2551,17 @@ let eval_tactic t gls = let interp t = interp_tac_gen [] [] (get_debug()) t let eval_ltac_constr gl t = - interp_ltac_constr + interp_ltac_constr { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } gl (intern_tactic (make_empty_glob_sign ()) t ) (* Hides interpretation for pretty-print *) let hide_interp t ot gl = - let ist = { ltacvars = ([],[]); ltacrecvars = []; + let ist = { ltacvars = ([],[]); ltacrecvars = []; gsigma = project gl; genv = pf_env gl } in let te = intern_tactic ist t in let t = eval_tactic te in - match ot with + match ot with | None -> abstract_tactic_expr (TacArg (Tacexp te)) t gl | Some t' -> abstract_tactic_expr ~dflt:true (TacArg (Tacexp te)) (tclTHEN t t') gl @@ -2487,13 +2605,13 @@ let subst_or_var f = function let subst_located f (_loc,id) = (dloc,f id) -let subst_reference subst = +let subst_reference subst = subst_or_var (subst_located (subst_kn subst)) (*CSC: subst_global_reference is used "only" for RefArgType, that propagates to the syntactic non-terminals "global", used in commands such as - Print. It is also used for non-evaluable references. *) -let subst_global_reference subst = + Print. It is also used for non-evaluable references. *) +let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in if not (eq_constr (constr_of_global ref') t') then @@ -2508,7 +2626,7 @@ let subst_evaluable subst = let subst_eval_ref = subst_evaluable_reference subst in subst_or_var (subst_and_short_name subst_eval_ref) -let subst_unfold subst (l,e) = +let subst_unfold subst (l,e) = (l,subst_evaluable subst e) let subst_flag subst red = @@ -2516,13 +2634,19 @@ let subst_flag subst red = let subst_constr_with_occurrences subst (l,c) = (l,subst_rawconstr subst c) +let subst_rawconstr_or_pattern subst (c,p) = + (subst_rawconstr subst c,subst_pattern subst p) + +let subst_pattern_with_occurrences subst (l,p) = + (l,subst_rawconstr_or_pattern subst p) + let subst_redexp subst = function | Unfold l -> Unfold (List.map (subst_unfold subst) l) | Fold l -> Fold (List.map (subst_rawconstr subst) l) | Cbv f -> Cbv (subst_flag subst f) | Lazy f -> Lazy (subst_flag subst f) | Pattern l -> Pattern (List.map (subst_constr_with_occurrences subst) l) - | Simpl o -> Simpl (Option.map (subst_constr_with_occurrences subst) o) + | Simpl o -> Simpl (Option.map (subst_pattern_with_occurrences subst) o) | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r let subst_raw_may_eval subst = function @@ -2532,8 +2656,8 @@ let subst_raw_may_eval subst = function | ConstrTerm c -> ConstrTerm (subst_rawconstr subst c) let subst_match_pattern subst = function - | Subterm (b,ido,pc) -> Subterm (b,ido,subst_pattern subst pc) - | Term pc -> Term (subst_pattern subst pc) + | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_rawconstr_or_pattern subst pc)) + | Term pc -> Term (subst_rawconstr_or_pattern subst pc) let rec subst_match_goal_hyps subst = function | Hyp (locs,mp) :: tl -> @@ -2584,10 +2708,10 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Derived basic tactics *) | TacSimpleInductionDestruct (isrec,h) as x -> x - | TacInductionDestruct (isrec,ev,l) -> - TacInductionDestruct (isrec,ev,List.map (fun (lc,cbo,ids,cls) -> + | TacInductionDestruct (isrec,ev,(l,cls)) -> + TacInductionDestruct (isrec,ev,(List.map (fun (lc,cbo,ids) -> List.map (subst_induction_arg subst) lc, - Option.map (subst_raw_with_bindings subst) cbo, ids, cls) l) + Option.map (subst_raw_with_bindings subst) cbo, ids) l, cls)) | TacDoubleInduction (h1,h2) as x -> x | TacDecomposeAnd c -> TacDecomposeAnd (subst_rawconstr subst c) | TacDecomposeOr c -> TacDecomposeOr (subst_rawconstr subst c) @@ -2607,23 +2731,23 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Constructors *) | TacLeft (ev,bl) -> TacLeft (ev,subst_bindings subst bl) | TacRight (ev,bl) -> TacRight (ev,subst_bindings subst bl) - | TacSplit (ev,b,bl) -> TacSplit (ev,b,subst_bindings subst bl) + | TacSplit (ev,b,bll) -> TacSplit (ev,b,List.map (subst_bindings subst) bll) | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (subst_tactic subst) t) | TacConstructor (ev,n,bl) -> TacConstructor (ev,n,subst_bindings subst bl) (* Conversion *) | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) - | TacChange (occl,c,cl) -> - TacChange (Option.map (subst_constr_with_occurrences subst) occl, + | TacChange (op,c,cl) -> + TacChange (Option.map (subst_rawconstr_or_pattern subst) op, subst_rawconstr subst c, cl) (* Equivalence relations *) | TacReflexivity | TacSymmetry _ as x -> x - | TacTransitivity c -> TacTransitivity (subst_rawconstr subst c) + | TacTransitivity c -> TacTransitivity (Option.map (subst_rawconstr subst) c) (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - TacRewrite (ev, + | TacRewrite (ev,l,cl,by) -> + TacRewrite (ev, List.map (fun (b,m,c) -> b,m,subst_raw_with_bindings subst c) l, cl,Option.map (subst_tactic subst) by) @@ -2677,14 +2801,14 @@ and subst_tacarg subst = function | MetaIdArg (_loc,_,_) -> assert false | TacCall (_loc,f,l) -> TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) - | TacExternal (_loc,com,req,la) -> + | TacExternal (_loc,com,req,la) -> TacExternal (_loc,com,req,List.map (subst_tacarg subst) la) | (TacVoid | IntroPattern _ | Integer _ | TacFreshId _) as x -> x | Tacexp t -> Tacexp (subst_tactic subst t) | TacDynamic(the_loc,t) as x -> - (match tag t with + (match Dyn.tag t with | "tactic" | "value" -> x - | "constr" -> + | "constr" -> TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t))) | s -> anomaly_loc (dloc, "Tacinterp.val_interp", str "Unknown dynamic: <" ++ str s ++ str ">")) @@ -2709,11 +2833,11 @@ and subst_genarg subst (x:glob_generic_argument) = | PreIdentArgType -> in_gen globwit_pre_ident (out_gen globwit_pre_ident x) | IntroPatternArgType -> in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x) - | IdentArgType b -> + | IdentArgType b -> in_gen (globwit_ident_gen b) (out_gen (globwit_ident_gen b) x) | VarArgType -> in_gen globwit_var (out_gen globwit_var x) | RefArgType -> - in_gen globwit_ref (subst_global_reference subst + in_gen globwit_ref (subst_global_reference subst (out_gen globwit_ref x)) | SortArgType -> in_gen globwit_sort (out_gen globwit_sort x) @@ -2723,7 +2847,7 @@ and subst_genarg subst (x:glob_generic_argument) = in_gen globwit_constr_may_eval (subst_raw_may_eval subst (out_gen globwit_constr_may_eval x)) | QuantHypArgType -> in_gen globwit_quant_hyp - (subst_declared_or_quantified_hypothesis subst + (subst_declared_or_quantified_hypothesis subst (out_gen globwit_quant_hyp x)) | RedExprArgType -> in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x)) @@ -2742,11 +2866,11 @@ and subst_genarg subst (x:glob_generic_argument) = | PairArgType _ -> app_pair (subst_genarg subst) (subst_genarg subst) x | ExtraArgType s -> match tactic_genarg_level s with - | Some n -> + | Some n -> (* Special treatment of tactic arguments *) in_gen (globwit_tactic n) (subst_tactic subst (out_gen (globwit_tactic n) x)) - | None -> + | None -> lookup_genarg_subst s subst x (***************************************************************************) @@ -2764,10 +2888,10 @@ let replace (kn,td) = mactab := Gmap.add kn td (Gmap.remove kn !mactab) type tacdef_kind = | NewTac of identifier | UpdateTac of ltac_constant -let load_md i ((sp,kn),defs) = +let load_md i ((sp,kn),(local,defs)) = let dp,_ = repr_path sp in let mp,dir,_ = repr_kn kn in - List.iter (fun (id,t) -> + List.iter (fun (id,t) -> match id with NewTac id -> let sp = Libnames.make_path dp id in @@ -2775,11 +2899,11 @@ let load_md i ((sp,kn),defs) = Nametab.push_tactic (Until i) sp kn; add (kn,t) | UpdateTac kn -> replace (kn,t)) defs - -let open_md i((sp,kn),defs) = + +let open_md i ((sp,kn),(local,defs)) = let dp,_ = repr_path sp in let mp,dir,_ = repr_kn kn in - List.iter (fun (id,t) -> + List.iter (fun (id,t) -> match id with NewTac id -> let sp = Libnames.make_path dp id in @@ -2789,13 +2913,17 @@ let open_md i((sp,kn),defs) = let cache_md x = load_md 1 x -let subst_kind subst id = +let subst_kind subst id = match id with | NewTac _ -> id - | UpdateTac kn -> UpdateTac (Mod_subst.subst_kn subst kn) + | UpdateTac kn -> UpdateTac (subst_kn subst kn) + +let subst_md (subst,(local,defs)) = + (local, + List.map (fun (id,t) -> (subst_kind subst id,subst_tactic subst t)) defs) -let subst_md (_,subst,defs) = - List.map (fun (id,t) -> (subst_kind subst id,subst_tactic subst t)) defs +let classify_md (local,defs as o) = + if local then Dispose else Substitute o let (inMD,outMD) = declare_object {(default_object "TAC-DEFINITION") with @@ -2803,8 +2931,7 @@ let (inMD,outMD) = load_function = load_md; open_function = open_md; subst_function = subst_md; - classify_function = (fun (_,o) -> Substitute o); - export_function = (fun x -> Some x)} + classify_function = classify_md} let print_ltac id = try @@ -2822,18 +2949,18 @@ open Libnames (* Adds a definition for tactics in the table *) let make_absolute_name ident repl = let loc = loc_of_reference ident in - try - let id, kn = + try + let id, kn = if repl then None, Nametab.locate_tactic (snd (qualid_of_reference ident)) - else let id = Pcoq.coerce_global_to_id ident in - Some id, Lib.make_kn id + else let id = coerce_reference_to_id ident in + Some id, Lib.make_kn id in if Gmap.mem kn !mactab then if repl then id, kn else user_err_loc (loc,"Tacinterp.add_tacdef", str "There is already an Ltac named " ++ pr_reference ident ++ str".") - else if is_atomic_kn kn then + else if is_atomic_kn kn then user_err_loc (loc,"Tacinterp.add_tacdef", str "Reserved Ltac name " ++ pr_reference ident ++ str".") else id, kn @@ -2841,21 +2968,12 @@ let make_absolute_name ident repl = user_err_loc (loc,"Tacinterp.add_tacdef", str "There is no Ltac named " ++ pr_reference ident ++ str".") -let rec filter_map f l = - let rec aux acc = function - [] -> acc - | hd :: tl -> - match f hd with - Some x -> aux (x :: acc) tl - | None -> aux acc tl - in aux [] l - -let add_tacdef isrec tacl = +let add_tacdef local isrec tacl = let rfun = List.map (fun (ident, b, _) -> make_absolute_name ident b) tacl in let ist = - {(make_empty_glob_sign()) with ltacrecvars = - if isrec then filter_map - (function (Some id, qid) -> Some (id, qid) | (None, _) -> None) rfun + {(make_empty_glob_sign()) with ltacrecvars = + if isrec then list_map_filter + (function (Some id, qid) -> Some (id, qid) | (None, _) -> None) rfun else []} in let gtacl = List.map2 (fun (_,b,def) (id, qid) -> @@ -2864,11 +2982,12 @@ let add_tacdef isrec tacl = (k, t)) tacl rfun in let id0 = fst (List.hd rfun) in - let _ = match id0 with Some id0 -> ignore(Lib.add_leaf id0 (inMD gtacl)) - | _ -> Lib.add_anonymous_leaf (inMD gtacl) in + let _ = match id0 with + | Some id0 -> ignore(Lib.add_leaf id0 (inMD (local,gtacl))) + | _ -> Lib.add_anonymous_leaf (inMD (local,gtacl)) in List.iter - (fun (id,b,_) -> - Flags.if_verbose msgnl (Libnames.pr_reference id ++ + (fun (id,b,_) -> + Flags.if_verbose msgnl (Libnames.pr_reference id ++ (if b then str " is redefined" else str " is defined"))) tacl @@ -2879,13 +2998,13 @@ let add_tacdef isrec tacl = let glob_tactic x = Flags.with_option strict_check (intern_tactic (make_empty_glob_sign ())) x -let glob_tactic_env l env x = +let glob_tactic_env l env x = Flags.with_option strict_check (intern_tactic { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env }) x -let interp_redexp env sigma r = +let interp_redexp env sigma r = let ist = { lfun=[]; avoid_ids=[]; debug=get_debug (); trace=[] } in let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in interp_red_expr ist sigma env (intern_red_expr gist r) @@ -2894,11 +3013,14 @@ let interp_redexp env sigma r = (* Embed tactics in raw or glob tactic expr *) let globTacticIn t = TacArg (TacDynamic (dummy_loc,tactic_in t)) -let tacticIn t = globTacticIn (fun ist -> glob_tactic (t ist)) +let tacticIn t = + globTacticIn (fun ist -> + try glob_tactic (t ist) + with e -> raise (AnomalyOnError ("Incorrect tactic expression", e))) let tacticOut = function | TacArg (TacDynamic (_,d)) -> - if (tag d) = "tactic" then + if (Dyn.tag d) = "tactic" then tactic_out d else anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic") @@ -2910,14 +3032,12 @@ let tacticOut = function (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = Auto.set_extern_interp - (fun l -> - let l = List.map (fun (id,c) -> (id,VConstr c)) l in + (fun l -> + let l = List.map (fun (id,c) -> (id,VConstr ([],c))) l in interp_tactic {lfun=l;avoid_ids=[];debug=get_debug(); trace=[]}) -let _ = Auto.set_extern_intern_tac +let _ = Auto.set_extern_intern_tac (fun l -> Flags.with_option strict_check (intern_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])})) let _ = Auto.set_extern_subst_tactic subst_tactic let _ = Dhyp.set_extern_interp eval_tactic -let _ = Dhyp.set_extern_intern_tac - (fun t -> intern_tactic (make_empty_glob_sign()) t) diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index b66bdb85..f1cdef7f 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -6,10 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tacinterp.mli 12102 2009-04-24 10:48:11Z herbelin $ i*) +(*i $Id$ i*) (*i*) -open Dyn open Pp open Util open Names @@ -27,12 +26,12 @@ open Redexpr (* Values for interpretation *) type value = | VRTactic of (goal list sigma * validation) - | VFun of ltac_trace * (identifier*value) list * + | VFun of ltac_trace * (identifier*value) list * identifier option list * glob_tactic_expr | VVoid | VInteger of int | VIntroPattern of intro_pattern_expr - | VConstr of constr + | VConstr of Pattern.constr_under_binders | VConstr_context of constr | VList of value list | VRec of (identifier*value) list ref * glob_tactic_expr @@ -44,8 +43,8 @@ and interp_sign = debug : debug_info; trace : ltac_trace } -val extract_ltac_vars : interp_sign -> Evd.evar_map -> Environ.env -> - Pretyping.var_map * Pretyping.unbound_ltac_var_map +val extract_ltac_constr_values : interp_sign -> Environ.env -> + Pretyping.ltac_var_map (* Transforms an id into a constr if possible *) val constr_of_id : Environ.env -> identifier -> constr @@ -53,7 +52,7 @@ val constr_of_id : Environ.env -> identifier -> constr (* To embed several objects in Coqast.t *) val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t val tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr) - + val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr val valueIn : value -> raw_tactic_arg @@ -67,7 +66,8 @@ val get_debug : unit -> debug_info (* Adds a definition for tactics in the table *) val add_tacdef : - bool -> (Libnames.reference * bool * raw_tactic_expr) list -> unit + Vernacexpr.locality_flag -> bool -> + (Libnames.reference * bool * raw_tactic_expr) list -> unit val add_primitive_tactic : string -> glob_tactic_expr -> unit (* Tactic extensions *) @@ -88,7 +88,7 @@ type glob_sign = { val add_interp_genarg : string -> (glob_sign -> raw_generic_argument -> glob_generic_argument) * - (interp_sign -> goal sigma -> glob_generic_argument -> + (interp_sign -> goal sigma -> glob_generic_argument -> typed_generic_argument) * (substitution -> glob_generic_argument -> glob_generic_argument) -> unit @@ -99,14 +99,14 @@ val interp_genarg : val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument -val intern_tactic : +val intern_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr val intern_constr : glob_sign -> constr_expr -> rawconstr_and_expr val intern_constr_with_bindings : - glob_sign -> constr_expr * constr_expr Rawterm.bindings -> + glob_sign -> constr_expr * constr_expr Rawterm.bindings -> rawconstr_and_expr * rawconstr_and_expr Rawterm.bindings val intern_hyp : @@ -122,7 +122,7 @@ val subst_rawconstr_and_expr : val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value (* Interprets an expression that evaluates to a constr *) -val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr -> +val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr -> constr (* Interprets redexp arguments *) @@ -134,8 +134,7 @@ val interp_tac_gen : (identifier * value) list -> identifier list -> val interp_hyp : interp_sign -> goal sigma -> identifier located -> identifier -val interp_bindings : interp_sign -> goal sigma -> rawconstr_and_expr Rawterm.bindings -> - Evd.open_constr Rawterm.bindings +val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> rawconstr_and_expr Rawterm.bindings -> Evd.evar_map * constr Rawterm.bindings (* Initial call for interpretation *) val glob_tactic : raw_tactic_expr -> glob_tactic_expr @@ -158,7 +157,7 @@ val hide_interp : raw_tactic_expr -> tactic option -> tactic val declare_implicit_tactic : tactic -> unit (* Declare the xml printer *) -val declare_xml_printer : +val declare_xml_printer : (out_channel -> Environ.env -> Evd.evar_map -> constr -> unit) -> unit (* printing *) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 3db6bcef..33285505 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacticals.ml 12102 2009-04-24 10:48:11Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -29,32 +29,29 @@ open Matching open Genarg open Tacexpr -(******************************************) -(* Basic Tacticals *) -(******************************************) - -(*************************************************) -(* Tacticals re-exported from the Refiner module.*) -(*************************************************) - -let tclNORMEVAR = tclNORMEVAR -let tclIDTAC = tclIDTAC -let tclIDTAC_MESSAGE = tclIDTAC_MESSAGE -let tclORELSE0 = tclORELSE0 -let tclORELSE = tclORELSE -let tclTHEN = tclTHEN -let tclTHENLIST = tclTHENLIST -let tclTHEN_i = tclTHEN_i -let tclTHENFIRST = tclTHENFIRST -let tclTHENLAST = tclTHENLAST -let tclTHENS = tclTHENS +(************************************************************************) +(* Tacticals re-exported from the Refiner module *) +(************************************************************************) + +let tclNORMEVAR = Refiner.tclNORMEVAR +let tclIDTAC = Refiner.tclIDTAC +let tclIDTAC_MESSAGE = Refiner.tclIDTAC_MESSAGE +let tclORELSE0 = Refiner.tclORELSE0 +let tclORELSE = Refiner.tclORELSE +let tclTHEN = Refiner.tclTHEN +let tclTHENLIST = Refiner.tclTHENLIST +let tclMAP = Refiner.tclMAP +let tclTHEN_i = Refiner.tclTHEN_i +let tclTHENFIRST = Refiner.tclTHENFIRST +let tclTHENLAST = Refiner.tclTHENLAST +let tclTHENS = Refiner.tclTHENS let tclTHENSV = Refiner.tclTHENSV let tclTHENSFIRSTn = Refiner.tclTHENSFIRSTn let tclTHENSLASTn = Refiner.tclTHENSLASTn let tclTHENFIRSTn = Refiner.tclTHENFIRSTn let tclTHENLASTn = Refiner.tclTHENLASTn let tclREPEAT = Refiner.tclREPEAT -let tclREPEAT_MAIN = tclREPEAT_MAIN +let tclREPEAT_MAIN = Refiner.tclREPEAT_MAIN let tclFIRST = Refiner.tclFIRST let tclSOLVE = Refiner.tclSOLVE let tclTRY = Refiner.tclTRY @@ -62,56 +59,66 @@ let tclINFO = Refiner.tclINFO let tclCOMPLETE = Refiner.tclCOMPLETE let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE let tclFAIL = Refiner.tclFAIL +let tclFAIL_lazy = Refiner.tclFAIL_lazy let tclDO = Refiner.tclDO let tclPROGRESS = Refiner.tclPROGRESS let tclWEAK_PROGRESS = Refiner.tclWEAK_PROGRESS let tclNOTSAMEGOAL = Refiner.tclNOTSAMEGOAL -let tclTHENTRY = tclTHENTRY -let tclIFTHENELSE = tclIFTHENELSE -let tclIFTHENSELSE = tclIFTHENSELSE -let tclIFTHENSVELSE = tclIFTHENSVELSE -let tclIFTHENTRYELSEMUST = tclIFTHENTRYELSEMUST +let tclTHENTRY = Refiner.tclTHENTRY +let tclIFTHENELSE = Refiner.tclIFTHENELSE +let tclIFTHENSELSE = Refiner.tclIFTHENSELSE +let tclIFTHENSVELSE = Refiner.tclIFTHENSVELSE +let tclIFTHENTRYELSEMUST = Refiner.tclIFTHENTRYELSEMUST + +(* Synonyms *) -let unTAC = unTAC +let tclTHENSEQ = tclTHENLIST -(* [rclTHENSEQ [t1;..;tn] is equivalent to t1;..;tn *) -let tclTHENSEQ = tclTHENLIST +(* Experimental *) -(* map_tactical f [x1..xn] = (f x1);(f x2);...(f xn) *) -(* tclMAP f [x1..xn] = (f x1);(f x2);...(f xn) *) -let tclMAP tacfun l = - List.fold_right (fun x -> (tclTHEN (tacfun x))) l tclIDTAC +let rec tclFIRST_PROGRESS_ON tac = function + | [] -> tclFAIL 0 (str "No applicable tactic") + | [a] -> tac a (* so that returned failure is the one from last item *) + | a::tl -> tclORELSE (tac a) (tclFIRST_PROGRESS_ON tac tl) -(* apply a tactic to the nth element of the signature *) +(************************************************************************) +(* Tacticals applying on hypotheses *) +(************************************************************************) -let tclNTH_HYP m (tac : constr->tactic) gl = - tac (try mkVar(let (id,_,_) = List.nth (pf_hyps gl) (m-1) in id) - with Failure _ -> error "No such assumption.") gl +let nthDecl m gl = + try List.nth (pf_hyps gl) (m-1) + with Failure _ -> error "No such assumption." -let tclNTH_DECL m tac gl = - tac (try List.nth (pf_hyps gl) (m-1) - with Failure _ -> error "No such assumption.") gl +let nthHypId m gl = pi1 (nthDecl m gl) +let nthHyp m gl = mkVar (nthHypId m gl) -(* apply a tactic to the last element of the signature *) +let lastDecl gl = nthDecl 1 gl +let lastHypId gl = nthHypId 1 gl +let lastHyp gl = nthHyp 1 gl -let tclLAST_HYP = tclNTH_HYP 1 +let nLastDecls n gl = + try list_firstn n (pf_hyps gl) + with Failure _ -> error "Not enough hypotheses in the goal." -let tclLAST_DECL = tclNTH_DECL 1 +let nLastHypsId n gl = List.map pi1 (nLastDecls n gl) +let nLastHyps n gl = List.map mkVar (nLastHypsId n gl) -let tclLAST_NHYPS n tac gl = - tac (try list_firstn n (pf_ids_of_hyps gl) - with Failure _ -> error "No such assumptions.") gl +let onNthDecl m tac gl = tac (nthDecl m gl) gl +let onNthHypId m tac gl = tac (nthHypId m gl) gl +let onNthHyp m tac gl = tac (nthHyp m gl) gl -let tclTRY_sign (tac : constr->tactic) sign gl = - let rec arec = function - | [] -> tclFAIL 0 (str "No applicable hypothesis.") - | [s] -> tac (mkVar s) (*added in order to get useful error messages *) - | (s::sl) -> tclORELSE (tac (mkVar s)) (arec sl) - in - arec (ids_of_named_context sign) gl +let onLastDecl = onNthDecl 1 +let onLastHypId = onNthHypId 1 +let onLastHyp = onNthHyp 1 -let tclTRY_HYPS (tac : constr->tactic) gl = - tclTRY_sign tac (pf_hyps gl) gl +let onHyps find tac gl = tac (find gl) gl + +let onNLastDecls n tac = onHyps (nLastDecls n) tac +let onNLastHypsId n tac = onHyps (nLastHypsId n) tac +let onNLastHyps n tac = onHyps (nLastHyps n) tac + +let afterHyp id gl = + fst (list_split_when (fun (hyp,_,_) -> hyp = id) (pf_hyps gl)) (***************************************) (* Clause Tacticals *) @@ -122,150 +129,122 @@ let tclTRY_HYPS (tac : constr->tactic) gl = or (Some id), where id is an identifier. This type is useful for defining tactics that may be used either to transform the conclusion (None) or to transform a hypothesis id (Some id). -- - --Eduardo (8/8/97) + --Eduardo (8/8/97) *) -(* The type of clauses *) +(* A [simple_clause] is a set of hypotheses, possibly extended with + the conclusion (conclusion is represented by None) *) + +type simple_clause = identifier option list + +(* An [clause] is the algebraic form of a + [concrete_clause]; it may refer to all hypotheses + independently of the effective contents of the current goal *) -type simple_clause = identifier gsimple_clause type clause = identifier gclause -let allClauses = { onhyps=None; concl_occs=all_occurrences_expr } +let allHypsAndConcl = { onhyps=None; concl_occs=all_occurrences_expr } let allHyps = { onhyps=None; concl_occs=no_occurrences_expr } let onConcl = { onhyps=Some[]; concl_occs=all_occurrences_expr } let onHyp id = - { onhyps=Some[((all_occurrences_expr,id),InHyp)]; concl_occs=no_occurrences_expr } - -let simple_clause_list_of cl gls = + { onhyps=Some[((all_occurrences_expr,id),InHyp)]; + concl_occs=no_occurrences_expr } + +let simple_clause_of cl gls = + let error_occurrences () = + error "This tactic does not support occurrences selection" in + let error_body_selection () = + error "This tactic does not support body selection" in let hyps = - match cl.onhyps with + match cl.onhyps with | None -> - let f id = Some((all_occurrences_expr,id),InHyp) in - List.map f (pf_ids_of_hyps gls) + List.map Option.make (pf_ids_of_hyps gls) | Some l -> - List.map (fun h -> Some h) l in - if cl.concl_occs = all_occurrences_expr then None::hyps else hyps - - -(* OR-branch *) -let tryClauses tac cl gls = - let rec firstrec = function - | [] -> tclFAIL 0 (str "no applicable hypothesis") - | [cls] -> tac cls (* added in order to get a useful error message *) - | cls::tl -> (tclORELSE (tac cls) (firstrec tl)) - in - let hyps = simple_clause_list_of cl gls in - firstrec hyps gls - -(* AND-branch *) -let onClauses tac cl gls = - let hyps = simple_clause_list_of cl gls in - tclMAP tac hyps gls - -(* AND-branch reverse order*) -let onClausesLR tac cl gls = - let hyps = simple_clause_list_of cl gls in - tclMAP tac (List.rev hyps) gls - -(* A clause corresponding to the |n|-th hypothesis or None *) - -let nth_clause n gl = - if n = 0 then - onConcl - else if n < 0 then - let id = List.nth (List.rev (pf_ids_of_hyps gl)) (-n-1) in - onHyp id - else - let id = List.nth (pf_ids_of_hyps gl) (n-1) in - onHyp id - -(* Gets the conclusion or the type of a given hypothesis *) - -let clause_type cls gl = - match simple_clause_of cls with - | None -> pf_concl gl - | Some ((_,id),_) -> pf_get_hyp_typ gl id - -(* Functions concerning matching of clausal environments *) - -let pf_is_matching gls pat n = - is_matching_conv (pf_env gls) (project gls) pat n - -let pf_matches gls pat n = - matches_conv (pf_env gls) (project gls) pat n - -(* [OnCL clausefinder clausetac] - * executes the clausefinder to find the clauses, and then executes the - * clausetac on the clause so obtained. *) - -let onCL cfind cltac gl = cltac (cfind gl) gl + List.map (fun ((occs,id),w) -> + if occs <> all_occurrences_expr then error_occurrences (); + if w = InHypValueOnly then error_body_selection (); + Some id) l in + if cl.concl_occs = no_occurrences_expr then hyps + else + if cl.concl_occs <> all_occurrences_expr then error_occurrences () + else None :: hyps +let fullGoal gl = None :: List.map Option.make (pf_ids_of_hyps gl) -(* [OnHyps hypsfinder hypstac] - * idem [OnCL] but only for hypotheses, not for conclusion *) - -let onHyps find tac gl = tac (find gl) gl +let onAllHyps tac gl = tclMAP tac (pf_ids_of_hyps gl) gl +let onAllHypsAndConcl tac gl = tclMAP tac (fullGoal gl) gl +let onAllHypsAndConclLR tac gl = tclMAP tac (List.rev (fullGoal gl)) gl +let tryAllHyps tac gl = tclFIRST_PROGRESS_ON tac (pf_ids_of_hyps gl) gl +let tryAllHypsAndConcl tac gl = tclFIRST_PROGRESS_ON tac (fullGoal gl) gl +let tryAllHypsAndConclLR tac gl = + tclFIRST_PROGRESS_ON tac (List.rev (fullGoal gl)) gl +let onClause tac cl gls = tclMAP tac (simple_clause_of cl gls) gls +let onClauseLR tac cl gls = tclMAP tac (List.rev (simple_clause_of cl gls)) gls -(* Create a clause list with all the hypotheses from the context, occuring - after id *) - -let afterHyp id gl = - fst (list_split_at (fun (hyp,_,_) -> hyp = id) (pf_hyps gl)) - +let ifOnHyp pred tac1 tac2 id gl = + if pred (id,pf_get_hyp_typ gl id) then + tac1 id gl + else + tac2 id gl -(* Create a singleton clause list with the last hypothesis from then context *) -let lastHyp gl = List.hd (pf_ids_of_hyps gl) +(************************************************************************) +(* An intermediate form of occurrence clause that select components *) +(* of a definition, hypotheses and possibly the goal *) +(* (used for reduction tactics) *) +(************************************************************************) +(* A [hyp_location] is an hypothesis together with a position, in + body if any, in type or in both *) -(* Create a clause list with the n last hypothesis from then context *) +type hyp_location = identifier * hyp_location_flag -let nLastHyps n gl = - try list_firstn n (pf_hyps gl) - with Failure "firstn" -> error "Not enough hypotheses in the goal." +(* A [goal_location] is either an hypothesis (together with a position, in + body if any, in type or in both) or the goal *) +type goal_location = hyp_location option -let onClause t cls gl = t cls gl -let tryAllClauses tac = tryClauses tac allClauses -let onAllClauses tac = onClauses tac allClauses -let onAllClausesLR tac = onClausesLR tac allClauses -let onNthLastHyp n tac gls = tac (nth_clause n gls) gls +(************************************************************************) +(* An intermediate structure for dealing with occurrence clauses *) +(************************************************************************) -let tryAllHyps tac = - tryClauses (function Some((_,id),_) -> tac id | _ -> assert false) allHyps -let onNLastHyps n tac = onHyps (nLastHyps n) (tclMAP tac) -let onLastHyp tac gls = tac (lastHyp gls) gls +(* [clause_atom] refers either to an hypothesis location (i.e. an + hypothesis with occurrences and a position, in body if any, in type + or in both) or to some occurrences of the conclusion *) -let clauseTacThen tac continuation = - (fun cls -> (tclTHEN (tac cls) continuation)) +type clause_atom = + | OnHyp of identifier * occurrences_expr * hyp_location_flag + | OnConcl of occurrences_expr -let if_tac pred tac1 tac2 gl = - if pred gl then tac1 gl else tac2 gl +(* A [concrete_clause] is an effective collection of + occurrences in the hypotheses and the conclusion *) -let ifOnClause pred tac1 tac2 cls gl = - if pred (cls,clause_type cls gl) then - tac1 cls gl - else - tac2 cls gl +type concrete_clause = clause_atom list -let ifOnHyp pred tac1 tac2 id gl = - if pred (id,pf_get_hyp_typ gl id) then - tac1 id gl - else - tac2 id gl +let concrete_clause_of cl gls = + let hyps = + match cl.onhyps with + | None -> + let f id = OnHyp (id,all_occurrences_expr,InHyp) in + List.map f (pf_ids_of_hyps gls) + | Some l -> + List.map (fun ((occs,id),w) -> OnHyp (id,occs,w)) l in + if cl.concl_occs = no_occurrences_expr then hyps + else + OnConcl cl.concl_occs :: hyps -(***************************************) -(* Elimination Tacticals *) -(***************************************) +(************************************************************************) +(* Elimination Tacticals *) +(************************************************************************) (* The following tacticals allow to apply a tactic to the branches generated by the application of an elimination - tactic. + tactic. Two auxiliary types --branch_args and branch_assumptions-- are - used to keep track of some information about the ``branches'' of + used to keep track of some information about the ``branches'' of the elimination. *) type branch_args = { @@ -283,18 +262,18 @@ type branch_assumptions = { assums : named_context} (* the list of assumptions introduced *) let fix_empty_or_and_pattern nv l = - (* 1- The syntax does not distinguish between "[ ]" for one clause with no + (* 1- The syntax does not distinguish between "[ ]" for one clause with no names and "[ ]" for no clause at all *) - (* 2- More generally, we admit "[ ]" for any disjunctive pattern of + (* 2- More generally, we admit "[ ]" for any disjunctive pattern of arbitrary length *) if l = [[]] then list_make nv [] else l let check_or_and_pattern_size loc names n = if List.length names <> n then - if n = 1 then + if n = 1 then user_err_loc (loc,"",str "Expects a conjunctive pattern.") - else - user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n + else + user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n ++ str " branches.") let compute_induction_names n = function @@ -309,7 +288,7 @@ let compute_induction_names n = function let compute_construtor_signatures isrec (_,k as ity) = let rec analrec c recargs = - match kind_of_term c, recargs with + match kind_of_term c, recargs with | Prod (_,_,c), recarg::rest -> let b = match dest_recarg recarg with | Norec | Imbr _ -> false @@ -318,7 +297,7 @@ let compute_construtor_signatures isrec (_,k as ity) = | LetIn (_,_,_,c), rest -> false :: (analrec c rest) | _, [] -> [] | _ -> anomaly "compute_construtor_signatures" - in + in let (mib,mip) = Global.lookup_inductive ity in let n = mib.mind_nparams in let lc = @@ -326,27 +305,27 @@ let compute_construtor_signatures isrec (_,k as ity) = let lrecargs = dest_subterms mip.mind_recargs in array_map2 analrec lc lrecargs -let elimination_sort_of_goal gl = +let elimination_sort_of_goal gl = pf_apply Retyping.get_sort_family_of gl (pf_concl gl) -let elimination_sort_of_hyp id gl = +let elimination_sort_of_hyp id gl = pf_apply Retyping.get_sort_family_of gl (pf_get_hyp_typ gl id) let elimination_sort_of_clause = function - | None -> elimination_sort_of_goal + | None -> elimination_sort_of_goal | Some id -> elimination_sort_of_hyp id (* Find the right elimination suffix corresponding to the sort of the goal *) (* c should be of type A1->.. An->B with B an inductive definition *) -let general_elim_then_using mk_elim - isrec allnames tac predicate (indbindings,elimbindings) +let general_elim_then_using mk_elim + isrec allnames tac predicate (indbindings,elimbindings) ind indclause gl = let elim = mk_elim ind gl in (* applying elimination_scheme just a little modified *) let indclause' = clenv_match_args indbindings indclause in let elimclause = mk_clenv_from gl (elim,pf_type_of gl elim) in - let indmv = + let indmv = match kind_of_term (last_arg elimclause.templval.Evd.rebus) with | Meta mv -> mv | _ -> anomaly "elimination" @@ -362,7 +341,7 @@ let general_elim_then_using mk_elim | Var id -> string_of_id id | _ -> "\b" in - error ("The elimination combinator " ^ name_elim ^ " is unknown.") + error ("The elimination combinator " ^ name_elim ^ " is unknown.") in let elimclause' = clenv_fchain indmv elimclause indclause' in let elimclause' = clenv_match_args elimbindings elimclause' in @@ -372,15 +351,15 @@ let general_elim_then_using mk_elim let (hd,largs) = decompose_app ce.templtyp.Evd.rebus in let ba = { branchsign = branchsigns.(i); branchnames = brnames.(i); - nassums = - List.fold_left + nassums = + List.fold_left (fun acc b -> if b then acc+2 else acc+1) 0 branchsigns.(i); branchnum = i+1; ity = ind; largs = List.map (clenv_nf_meta ce) largs; pred = clenv_nf_meta ce hd } - in + in tac ba gl in let branchtacs ce = Array.init (Array.length branchsigns) (after_tac ce) in @@ -389,7 +368,7 @@ let general_elim_then_using mk_elim | None -> elimclause' | Some p -> clenv_unify true Reduction.CONV (mkMeta pmv) p elimclause' - in + in elim_res_pf_THEN_i elimclause' branchtacs gl (* computing the case/elim combinators *) @@ -398,12 +377,14 @@ let gl_make_elim ind gl = Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) let gl_make_case_dep ind gl = - pf_apply Indrec.make_case_dep gl ind (elimination_sort_of_goal gl) + pf_apply Indrec.build_case_analysis_scheme gl ind true + (elimination_sort_of_goal gl) let gl_make_case_nodep ind gl = - pf_apply Indrec.make_case_nodep gl ind (elimination_sort_of_goal gl) + pf_apply Indrec.build_case_analysis_scheme gl ind false + (elimination_sort_of_goal gl) -let elimination_then_using tac predicate bindings c gl = +let elimination_then_using tac predicate bindings c gl = let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let indclause = mk_clenv_from gl (c,t) in general_elim_then_using gl_make_elim @@ -415,14 +396,14 @@ let case_then_using = let case_nodep_then_using = general_elim_then_using gl_make_case_nodep false -let elimination_then tac = elimination_then_using tac None +let elimination_then tac = elimination_then_using tac None let simple_elimination_then tac = elimination_then tac ([],[]) -let make_elim_branch_assumptions ba gl = +let make_elim_branch_assumptions ba gl = let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc = - match lb,lc with - | ([], _) -> + match lb,lc with + | ([], _) -> { ba = ba; assums = assums} | ((true::tl), ((idrec,_,_ as recarg)::(idind,_,_ as indarg)::idtl)) -> @@ -438,7 +419,7 @@ let make_elim_branch_assumptions ba gl = recargs, indargs) tl idtl | (_, _) -> anomaly "make_elim_branch_assumptions" - in + in makerec ([],[],[],[],[]) ba.branchsign (try list_firstn ba.nassums (pf_hyps gl) with Failure _ -> anomaly "make_elim_branch_assumptions") @@ -447,8 +428,8 @@ let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl let make_case_branch_assumptions ba gl = let rec makerec (assums,cargs,constargs,recargs) p_0 p_1 = - match p_0,p_1 with - | ([], _) -> + match p_0,p_1 with + | ([], _) -> { ba = ba; assums = assums} | ((true::tl), ((idrec,_,_ as recarg)::idtl)) -> @@ -462,7 +443,7 @@ let make_case_branch_assumptions ba gl = recargs, id::constargs) tl idtl | (_, _) -> anomaly "make_case_branch_assumptions" - in + in makerec ([],[],[],[]) ba.branchsign (try list_firstn ba.nassums (pf_hyps gl) with Failure _ -> anomaly "make_case_branch_assumptions") diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 25a0d897..b9c8ab92 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tacticals.mli 11735 2009-01-02 17:22:31Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Pp @@ -21,6 +21,8 @@ open Reduction open Pattern open Genarg open Tacexpr +open Termops +open Rawterm (*i*) (* Tacticals i.e. functions from tactics to tactics. *) @@ -51,76 +53,112 @@ val tclINFO : tactic -> tactic val tclCOMPLETE : tactic -> tactic val tclAT_LEAST_ONCE : tactic -> tactic val tclFAIL : int -> std_ppcmds -> tactic +val tclFAIL_lazy : int -> std_ppcmds Lazy.t -> tactic val tclDO : int -> tactic -> tactic val tclPROGRESS : tactic -> tactic val tclWEAK_PROGRESS : tactic -> tactic val tclNOTSAMEGOAL : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic - -val tclNTH_HYP : int -> (constr -> tactic) -> tactic -val tclNTH_DECL : int -> (named_declaration -> tactic) -> tactic val tclMAP : ('a -> tactic) -> 'a list -> tactic -val tclLAST_HYP : (constr -> tactic) -> tactic -val tclLAST_DECL : (named_declaration -> tactic) -> tactic -val tclLAST_NHYPS : int -> (identifier list -> tactic) -> tactic -val tclTRY_sign : (constr -> tactic) -> named_context -> tactic -val tclTRY_HYPS : (constr -> tactic) -> tactic - -val tclIFTHENELSE : tactic -> tactic -> tactic -> tactic -val tclIFTHENSELSE : tactic -> tactic list -> tactic -> tactic -val tclIFTHENSVELSE : tactic -> tactic array -> tactic -> tactic +val tclIFTHENELSE : tactic -> tactic -> tactic -> tactic +val tclIFTHENSELSE : tactic -> tactic list -> tactic -> tactic +val tclIFTHENSVELSE : tactic -> tactic array -> tactic -> tactic val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic -val unTAC : tactic -> goal sigma -> proof_tree sigma +val tclFIRST_PROGRESS_ON : ('a -> tactic) -> 'a list -> tactic + +(*s Tacticals applying to hypotheses *) + +val onNthHypId : int -> (identifier -> tactic) -> tactic +val onNthHyp : int -> (constr -> tactic) -> tactic +val onNthDecl : int -> (named_declaration -> tactic) -> tactic +val onLastHypId : (identifier -> tactic) -> tactic +val onLastHyp : (constr -> tactic) -> tactic +val onLastDecl : (named_declaration -> tactic) -> tactic +val onNLastHypsId : int -> (identifier list -> tactic) -> tactic +val onNLastHyps : int -> (constr list -> tactic) -> tactic +val onNLastDecls : int -> (named_context -> tactic) -> tactic + +val lastHypId : goal sigma -> identifier +val lastHyp : goal sigma -> constr +val lastDecl : goal sigma -> named_declaration +val nLastHypsId : int -> goal sigma -> identifier list +val nLastHyps : int -> goal sigma -> constr list +val nLastDecls : int -> goal sigma -> named_context + +val afterHyp : identifier -> goal sigma -> named_context + +val ifOnHyp : (identifier * types -> bool) -> + (identifier -> tactic) -> (identifier -> tactic) -> + identifier -> tactic -(*s Clause tacticals. *) +val onHyps : (goal sigma -> named_context) -> + (named_context -> tactic) -> tactic + +(*s Tacticals applying to goal components *) + +(* A [simple_clause] is a set of hypotheses, possibly extended with + the conclusion (conclusion is represented by None) *) + +type simple_clause = identifier option list + +(* A [clause] denotes occurrences and hypotheses in a + goal; in particular, it can abstractly refer to the set of + hypotheses independently of the effective contents of the current goal *) -type simple_clause = identifier gsimple_clause type clause = identifier gclause -val allClauses : 'a gclause -val allHyps : clause -val onHyp : identifier -> clause -val onConcl : 'a gclause - -val nth_clause : int -> goal sigma -> clause -val clause_type : clause -> goal sigma -> constr -val simple_clause_list_of : clause -> goal sigma -> simple_clause list - -val pf_matches : goal sigma -> constr_pattern -> constr -> patvar_map -val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool - -val afterHyp : identifier -> goal sigma -> named_context -val lastHyp : goal sigma -> identifier -val nLastHyps : int -> goal sigma -> named_context - -val onCL : (goal sigma -> clause) -> - (clause -> tactic) -> tactic -val tryAllClauses : (simple_clause -> tactic) -> tactic -val onAllClauses : (simple_clause -> tactic) -> tactic -val onClause : (clause -> tactic) -> clause -> tactic -val onClauses : (simple_clause -> tactic) -> clause -> tactic -val onAllClausesLR : (simple_clause -> tactic) -> tactic -val onNthLastHyp : int -> (clause -> tactic) -> tactic -val clauseTacThen : (clause -> tactic) -> tactic -> clause -> tactic -val if_tac : (goal sigma -> bool) -> tactic -> (tactic) -> tactic -val ifOnClause : - (clause * types -> bool) -> - (clause -> tactic) -> (clause -> tactic) -> clause -> tactic -val ifOnHyp : - (identifier * types -> bool) -> - (identifier -> tactic) -> (identifier -> tactic) -> identifier -> tactic - -val onHyps : (goal sigma -> named_context) -> - (named_context -> tactic) -> tactic -val tryAllHyps : (identifier -> tactic) -> tactic -val onNLastHyps : int -> (named_declaration -> tactic) -> tactic -val onLastHyp : (identifier -> tactic) -> tactic +val simple_clause_of : clause -> goal sigma -> simple_clause + +val allHypsAndConcl : clause +val allHyps : clause +val onHyp : identifier -> clause +val onConcl : clause + +val tryAllHyps : (identifier -> tactic) -> tactic +val tryAllHypsAndConcl : (identifier option -> tactic) -> tactic + +val onAllHyps : (identifier -> tactic) -> tactic +val onAllHypsAndConcl : (identifier option -> tactic) -> tactic +val onAllHypsAndConclLR : (identifier option -> tactic) -> tactic + +val onClause : (identifier option -> tactic) -> clause -> tactic +val onClauseLR : (identifier option -> tactic) -> clause -> tactic + +(*s An intermediate form of occurrence clause with no mention of occurrences *) + +(* A [hyp_location] is an hypothesis together with a position, in + body if any, in type or in both *) + +type hyp_location = identifier * hyp_location_flag + +(* A [goal_location] is either an hypothesis (together with a position, in + body if any, in type or in both) or the goal *) + +type goal_location = hyp_location option + +(*s A concrete view of occurrence clauses *) + +(* [clause_atom] refers either to an hypothesis location (i.e. an + hypothesis with occurrences and a position, in body if any, in type + or in both) or to some occurrences of the conclusion *) + +type clause_atom = + | OnHyp of identifier * occurrences_expr * hyp_location_flag + | OnConcl of occurrences_expr + +(* A [concrete_clause] is an effective collection of + occurrences in the hypotheses and the conclusion *) + +type concrete_clause = clause_atom list + +(* This interprets an [clause] in a given [goal] context *) +val concrete_clause_of : clause -> goal sigma -> concrete_clause (*s Elimination tacticals. *) -type branch_args = { +type branch_args = { ity : inductive; (* the type we were eliminating on *) largs : constr list; (* its arguments *) branchnum : int; (* the branch number *) @@ -137,15 +175,15 @@ type branch_assumptions = { (* [check_disjunctive_pattern_size loc pats n] returns an appropriate *) (* error message if |pats| <> n *) val check_or_and_pattern_size : - Util.loc -> or_and_intro_pattern_expr -> int -> unit + Util.loc -> or_and_intro_pattern_expr -> int -> unit (* Tolerate "[]" to mean a disjunctive pattern of any length *) -val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr -> +val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr -> or_and_intro_pattern_expr (* Useful for [as intro_pattern] modifier *) -val compute_induction_names : - int -> intro_pattern_expr located option -> +val compute_induction_names : + int -> intro_pattern_expr located option -> intro_pattern_expr located list array val elimination_sort_of_goal : goal sigma -> sorts_family @@ -154,30 +192,30 @@ val elimination_sort_of_clause : identifier option -> goal sigma -> sorts_family val general_elim_then_using : (inductive -> goal sigma -> constr) -> rec_flag -> - intro_pattern_expr located option -> (branch_args -> tactic) -> + intro_pattern_expr located option -> (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic - + val elimination_then_using : - (branch_args -> tactic) -> constr option -> + (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> constr -> tactic val elimination_then : - (branch_args -> tactic) -> + (branch_args -> tactic) -> (arg_bindings * arg_bindings) -> constr -> tactic val case_then_using : - intro_pattern_expr located option -> (branch_args -> tactic) -> + intro_pattern_expr located option -> (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic val case_nodep_then_using : - intro_pattern_expr located option -> (branch_args -> tactic) -> - constr option -> (arg_bindings * arg_bindings) -> + intro_pattern_expr located option -> (branch_args -> tactic) -> + constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic val simple_elimination_then : (branch_args -> tactic) -> constr -> tactic -val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic -val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic +val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic +val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0a4c0fbe..69bc0653 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tactics.ml 12956 2010-04-20 08:49:15Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -15,6 +15,7 @@ open Nameops open Sign open Term open Termops +open Namegen open Declarations open Inductive open Inductiveops @@ -58,24 +59,38 @@ let rec nb_prod x = let inj_with_occurrences e = (all_occurrences_expr,e) -let inj_open c = (Evd.empty,c) +let dloc = dummy_loc -let inj_occ (occ,c) = (occ,inj_open c) +(* Option for 8.2 compatibility *) +open Goptions +let dependent_propositions_elimination = ref true -let inj_red_expr = function - | Simpl lo -> Simpl (Option.map inj_occ lo) - | Fold l -> Fold (List.map inj_open l) - | Pattern l -> Pattern (List.map inj_occ l) - | (ExtraRedExpr _ | CbvVm | Red _ | Hnf | Cbv _ | Lazy _ | Unfold _ as c) - -> c +let use_dependent_propositions_elimination () = + !dependent_propositions_elimination + && Flags.version_strictly_greater Flags.V8_2 -let inj_ebindings = function - | NoBindings -> NoBindings - | ImplicitBindings l -> ImplicitBindings (List.map inj_open l) - | ExplicitBindings l -> - ExplicitBindings (List.map (fun (l,id,c) -> (l,id,inj_open c)) l) +let _ = + declare_bool_option + { optsync = true; + optname = "dependent-propositions-elimination tactic"; + optkey = ["Dependent";"Propositions";"Elimination"]; + optread = (fun () -> !dependent_propositions_elimination) ; + optwrite = (fun b -> dependent_propositions_elimination := b) } + +let apply_in_side_conditions_come_first = ref true + +let use_apply_in_side_conditions_come_first () = + !apply_in_side_conditions_come_first + && Flags.version_strictly_greater Flags.V8_2 + +let _ = + declare_bool_option + { optsync = true; + optname = "apply-in side-conditions coming first"; + optkey = ["Side";"Conditions";"First";"For";"apply";"in"]; + optread = (fun () -> !dependent_propositions_elimination) ; + optwrite = (fun b -> dependent_propositions_elimination := b) } -let dloc = dummy_loc (*********************************************) (* Tactics *) @@ -85,10 +100,10 @@ let dloc = dummy_loc (* General functions *) (****************************************) -let string_of_inductive c = +let string_of_inductive c = try match kind_of_term c with - | Ind ind_sp -> - let (mib,mip) = Global.lookup_inductive ind_sp in + | Ind ind_sp -> + let (mib,mip) = Global.lookup_inductive ind_sp in string_of_id mip.mind_typename | _ -> raise Bound with Bound -> error "Bound head variable." @@ -101,14 +116,14 @@ let rec head_constr_bound t = | Const _ | Ind _ | Construct _ | Var _ -> (hd,args) | _ -> raise Bound -let head_constr c = +let head_constr c = try head_constr_bound c with Bound -> error "Bound head variable." (******************************************) (* Primitive tactics *) (******************************************) -let introduction = Tacmach.introduction +let introduction = Tacmach.introduction let refine = Tacmach.refine let convert_concl = Tacmach.convert_concl let convert_hyp = Tacmach.convert_hyp @@ -117,16 +132,16 @@ let thin_body = Tacmach.thin_body let error_clear_dependency env id = function | Evarutil.OccurHypInSimpleClause None -> errorlabstrm "" (pr_id id ++ str " is used in conclusion.") - | Evarutil.OccurHypInSimpleClause (Some id') -> + | Evarutil.OccurHypInSimpleClause (Some id') -> errorlabstrm "" (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str".") | Evarutil.EvarTypingBreak ev -> errorlabstrm "" - (str "Cannot remove " ++ pr_id id ++ - strbrk " without breaking the typing of " ++ + (str "Cannot remove " ++ pr_id id ++ + strbrk " without breaking the typing of " ++ Printer.pr_existential env ev ++ str".") -let thin l gl = +let thin l gl = try thin l gl with Evarutil.ClearDependencyError (id,err) -> error_clear_dependency (pf_env gl) id err @@ -148,7 +163,7 @@ let internal_cut_rev = internal_cut_rev_gen false let internal_cut_rev_replace = internal_cut_rev_gen true (* Moving hypotheses *) -let move_hyp = Tacmach.move_hyp +let move_hyp = Tacmach.move_hyp let order_hyps = Tacmach.order_hyps @@ -159,11 +174,11 @@ let rename_hyp = Tacmach.rename_hyp (* Fresh names *) (**************************************************************) -let fresh_id_avoid avoid id = - next_global_ident_away true id avoid +let fresh_id_in_env avoid id env = + next_ident_away_in_goal id (avoid@ids_of_named_context (named_context env)) let fresh_id avoid id gl = - fresh_id_avoid (avoid@(pf_ids_of_hyps gl)) id + fresh_id_in_env avoid id (pf_env gl) (**************************************************************) (* Fixpoints and CoFixpoints *) @@ -173,19 +188,19 @@ let fresh_id avoid id gl = let mutual_fix = Tacmach.mutual_fix let fix ido n gl = match ido with - | None -> - mutual_fix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) n [] gl + | None -> + mutual_fix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) n [] 0 gl | Some id -> - mutual_fix id n [] gl + mutual_fix id n [] 0 gl (* Refine as a cofixpoint *) let mutual_cofix = Tacmach.mutual_cofix let cofix ido gl = match ido with - | None -> - mutual_cofix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) [] gl + | None -> + mutual_cofix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) [] 0 gl | Some id -> - mutual_cofix id [] gl + mutual_cofix id [] 0 gl (**************************************************************) (* Reduction and conversion tactics *) @@ -196,7 +211,7 @@ type tactic_reduction = env -> evar_map -> constr -> constr let pf_reduce_decl redfun where (id,c,ty) gl = let redfun' = pf_reduce redfun gl in match c with - | None -> + | None -> if where = InHypValueOnly then errorlabstrm "" (pr_id id ++ str "has no value."); (id,None,redfun' ty) @@ -205,39 +220,88 @@ let pf_reduce_decl redfun where (id,c,ty) gl = let ty' = if where <> InHypValueOnly then redfun' ty else ty in (id,Some b',ty') +(* Possibly equip a reduction with the occurrences mentioned in an + occurrence clause *) + +let error_illegal_clause () = + error "\"at\" clause not supported in presence of an occurrence clause." + +let error_illegal_non_atomic_clause () = + error "\"at\" clause not supported in presence of a non atomic \"in\" clause." + +let error_occurrences_not_unsupported () = + error "Occurrences not supported for this reduction tactic." + +let bind_change_occurrences occs = function + | None -> None + | Some c -> Some (Redexpr.out_with_occurrences (occs,c)) + +let bind_red_expr_occurrences occs nbcl redexp = + let has_at_clause = function + | Unfold l -> List.exists (fun (occl,_) -> occl <> all_occurrences_expr) l + | Pattern l -> List.exists (fun (occl,_) -> occl <> all_occurrences_expr) l + | Simpl (Some (occl,_)) -> occl <> all_occurrences_expr + | _ -> false in + if occs = all_occurrences_expr then + if nbcl > 1 && has_at_clause redexp then + error_illegal_non_atomic_clause () + else + redexp + else + match redexp with + | Unfold (_::_::_) -> + error_illegal_clause () + | Unfold [(occl,c)] -> + if occl <> all_occurrences_expr then + error_illegal_clause () + else + Unfold [(occs,c)] + | Pattern (_::_::_) -> + error_illegal_clause () + | Pattern [(occl,c)] -> + if occl <> all_occurrences_expr then + error_illegal_clause () + else + Pattern [(occs,c)] + | Simpl (Some (occl,c)) -> + if occl <> all_occurrences_expr then + error_illegal_clause () + else + Simpl (Some (occs,c)) + | Red _ | Hnf | Cbv _ | Lazy _ + | ExtraRedExpr _ | CbvVm | Fold _ | Simpl None -> + error_occurrences_not_unsupported () + | Unfold [] | Pattern [] -> + assert false + (* The following two tactics apply an arbitrary - reduction function either to the conclusion or to a + reduction function either to the conclusion or to a certain hypothesis *) -let reduct_in_concl (redfun,sty) gl = +let reduct_in_concl (redfun,sty) gl = convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl -let reduct_in_hyp redfun ((_,id),where) gl = +let reduct_in_hyp redfun (id,where) gl = convert_hyp_no_check - (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl + (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl let reduct_option redfun = function - | Some id -> reduct_in_hyp (fst redfun) id - | None -> reduct_in_concl redfun - -(* The following tactic determines whether the reduction - function has to be applied to the conclusion or - to the hypotheses. *) - -let redin_combinator redfun = - onClauses (reduct_option redfun) + | Some id -> reduct_in_hyp (fst redfun) id + | None -> reduct_in_concl redfun (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb t env sigma c = - if is_fconv cv_pb env sigma t c then + if is_fconv cv_pb env sigma t c then t - else + else errorlabstrm "convert-check-hyp" (str "Not convertible.") -(* Use cumulutavity only if changing the conclusion not a subterm *) +(* Use cumulativity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb t = function | None -> change_and_check cv_pb t - | Some occl -> contextually false occl (change_and_check Reduction.CONV t) + | Some occl -> + contextually false occl + (fun subst -> change_and_check Reduction.CONV (replace_vars subst t)) let change_in_concl occl t = reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) @@ -246,56 +310,20 @@ let change_in_hyp occl t id = with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id) let change_option occl t = function - Some id -> change_in_hyp occl t id + | Some id -> change_in_hyp occl t id | None -> change_in_concl occl t -let out_arg = function - | ArgVar _ -> anomaly "Unevaluated or_var variable" - | ArgArg x -> x - -let adjust_clause occl cls = - (* warn as much as possible on loss of occurrence information *) - (match cls, occl with - ({onhyps=(Some(_::_::_)|None)} - |{onhyps=Some(_::_);concl_occs=((false,_)|(true,_::_))}), - Some _ -> - error "No occurrences expected when changing several hypotheses." - | _ -> ()); - (* get at clause from cls if only goal or one hyp specified *) - let occl,cls = match occl with - | None -> None,cls - | Some (occs,c) -> - if cls.onhyps=Some[] && occs=all_occurrences then - Some (on_snd (List.map out_arg) cls.concl_occs,c), - {cls with concl_occs=all_occurrences_expr} - else - match cls.onhyps with - | Some[(occs',id),l] when - cls.concl_occs=no_occurrences_expr && occs=all_occurrences -> - Some (on_snd (List.map out_arg) occs',c), - {cls with onhyps=Some[(all_occurrences_expr,id),l]} - | _ -> - occl,cls in - (* check if cls has still specified occs *) - if cls.onhyps <> None && - List.exists (fun ((occs,_),_) -> occs <> all_occurrences_expr) - (Option.get cls.onhyps) - || cls.concl_occs <> all_occurrences_expr && - cls.concl_occs <> no_occurrences_expr - then - Flags.if_verbose Pp.msg_warning - (if cls.onhyps=Some[] then - str "Trailing \"at\" modifier not taken into account." - else - str "\"at\" modifier in clause \"in\" not taken into account."); - (* Anticipate on onClauses which removes concl if not at all occs *) - if cls.concl_occs=no_occurrences_expr then cls - else {cls with concl_occs=all_occurrences_expr} - -let change occl c cls = - onClauses (change_option occl c) (adjust_clause occl cls) +let change chg c cls gl = + let cls = concrete_clause_of cls gl in + tclMAP (function + | OnHyp (id,occs,where) -> + change_option (bind_change_occurrences occs chg) c (Some (id,where)) + | OnConcl occs -> + change_option (bind_change_occurrences occs chg) c None) + cls gl (* Pour usage interne (le niveau User est pris en compte par reduce) *) +let try_red_in_concl = reduct_in_concl (try_red_product,DEFAULTcast) let red_in_concl = reduct_in_concl (red_product,DEFAULTcast) let red_in_hyp = reduct_in_hyp red_product let red_option = reduct_option (red_product,DEFAULTcast) @@ -310,8 +338,8 @@ let normalise_in_hyp = reduct_in_hyp compute let normalise_option = reduct_option (compute,DEFAULTcast) let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,DEFAULTcast) -let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) -let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) +let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) +let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast) (* A function which reduces accordingly to a reduction expression, @@ -324,15 +352,28 @@ let checking_fun = function | Pattern _ -> with_check | _ -> (fun x -> x) +(* The main reduction function *) + +let reduction_clause redexp cl = + let nbcl = List.length cl in + List.map (function + | OnHyp (id,occs,where) -> + (Some (id,where), bind_red_expr_occurrences occs nbcl redexp) + | OnConcl occs -> + (None, bind_red_expr_occurrences occs nbcl redexp)) cl + let reduce redexp cl goal = - let red = Redexpr.reduction_of_red_expr redexp in + let cl = concrete_clause_of cl goal in + let redexps = reduction_clause redexp cl in + let tac = tclMAP (fun (where,redexp) -> + reduct_option (Redexpr.reduction_of_red_expr redexp) where) redexps in match redexp with - (Fold _|Pattern _) -> with_check (redin_combinator red cl) goal - | _ -> redin_combinator red cl goal + | Fold _ | Pattern _ -> with_check tac goal + | _ -> tac goal (* Unfolding occurrences of a constant *) -let unfold_constr = function +let unfold_constr = function | ConstRef sp -> unfold_in_concl [all_occurrences,EvalConstRef sp] | VarRef id -> unfold_in_concl [all_occurrences,EvalVarRef id] | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") @@ -357,7 +398,7 @@ let default_id env sigma = function | (name,Some b,_) -> id_of_name_using_hdchar env b name (* Non primitive introduction tactics are treated by central_intro - There is possibly renaming, with possibly names to avoid and + There is possibly renaming, with possibly names to avoid and possibly a move to do after the introduction *) type intro_name_flag = @@ -366,12 +407,13 @@ type intro_name_flag = | IntroMustBe of identifier let find_name loc decl gl = function - | IntroAvoid idl -> + | IntroAvoid idl -> (* this case must be compatible with [find_intro_names] below. *) let id = fresh_id idl (default_id (pf_env gl) gl.sigma decl) gl in id | IntroBasedOn (id,idl) -> fresh_id idl id gl - | IntroMustBe id -> - let id' = fresh_id [] id gl in + | IntroMustBe id -> + (* When name is given, we allow to hide a global name *) + let id' = next_ident_away id (pf_ids_of_hyps gl) in if id'<>id then user_err_loc (loc,"",pr_id id ++ str" is already used."); id' @@ -380,46 +422,42 @@ let find_name loc decl gl = function iteration of [find_name] above. As [default_id] checks the sort of the type to build hyp names, we maintain an environment to be able to type dependent hyps. *) -let find_intro_names ctxt gl = - let _, res = List.fold_right - (fun decl acc -> +let find_intro_names ctxt gl = + let _, res = List.fold_right + (fun decl acc -> let wantedname,x,typdecl = decl in let env,idl = acc in let name = fresh_id idl (default_id env gl.sigma decl) gl in let newenv = push_rel (wantedname,x,typdecl) env in (newenv,(name::idl))) ctxt (pf_env gl , []) in - List.rev res + List.rev res let build_intro_tac id = function | MoveToEnd true -> introduction id | dest -> tclTHEN (introduction id) (move_hyp true id dest) -let rec intro_gen loc name_flag move_flag force_flag gl = +let rec intro_gen loc name_flag move_flag force_flag dep_flag gl = match kind_of_term (pf_concl gl) with - | Prod (name,t,_) -> + | Prod (name,t,u) when not dep_flag or (dependent (mkRel 1) u) -> build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag gl - | LetIn (name,b,t,_) -> + | LetIn (name,b,t,u) when not dep_flag or (dependent (mkRel 1) u) -> build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag gl - | _ -> + | _ -> if not force_flag then raise (RefinerError IntroNeedsProduct); try - tclTHEN - (reduce (Red true) onConcl) - (intro_gen loc name_flag move_flag force_flag) gl + tclTHEN try_red_in_concl + (intro_gen loc name_flag move_flag force_flag dep_flag) gl with Redelimination -> user_err_loc(loc,"Intro",str "No product even after head-reduction.") -let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true -let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false -let intro_force force_flag = intro_gen dloc (IntroAvoid []) no_move force_flag -let intro = intro_force false -let introf = intro_force true - -let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false - -let introf_move_name destopt = intro_gen dloc (IntroAvoid []) destopt true +let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true false +let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false false +let intro = intro_gen dloc (IntroAvoid []) no_move false false +let introf = intro_gen dloc (IntroAvoid []) no_move true false +let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false false +let introf_move_name destopt = intro_gen dloc (IntroAvoid []) destopt true false (**** Multiple introduction tactics ****) @@ -427,10 +465,13 @@ let rec intros_using = function | [] -> tclIDTAC | str::l -> tclTHEN (intro_using str) (intros_using l) -let intros = tclREPEAT (intro_force false) +let intros = tclREPEAT intro let intro_erasing id = tclTHEN (thin [id]) (introduction id) +let intro_forthcoming_gen loc name_flag move_flag dep_flag = + tclREPEAT (intro_gen loc name_flag move_flag false dep_flag) + let rec get_next_hyp_position id = function | [] -> error ("No such hypothesis: " ^ string_of_id id) | (hyp,_,_) :: right -> @@ -445,14 +486,14 @@ let thin_for_replacing l gl = | Evarutil.OccurHypInSimpleClause None -> errorlabstrm "" (str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion.") - | Evarutil.OccurHypInSimpleClause (Some id') -> + | Evarutil.OccurHypInSimpleClause (Some id') -> errorlabstrm "" - (str "Cannot change " ++ pr_id id ++ + (str "Cannot change " ++ pr_id id ++ strbrk ", it is used in hypothesis " ++ pr_id id' ++ str".") | Evarutil.EvarTypingBreak ev -> errorlabstrm "" - (str "Cannot change " ++ pr_id id ++ - strbrk " without breaking the typing of " ++ + (str "Cannot change " ++ pr_id id ++ + strbrk " without breaking the typing of " ++ Printer.pr_existential (pf_env gl) ev ++ str".") let intro_replacing id gl = @@ -460,32 +501,32 @@ let intro_replacing id gl = tclTHENLIST [thin_for_replacing [id]; introduction id; move_hyp true id next_hyp] gl -let intros_replacing ids gl = +let intros_replacing ids gl = let rec introrec = function | [] -> tclIDTAC | id::tl -> tclTHEN (tclORELSE (intro_replacing id) (intro_using id)) (introrec tl) - in + in introrec ids gl (* User-level introduction tactics *) let intro_move idopt hto = match idopt with - | None -> intro_gen dloc (IntroAvoid []) hto true - | Some id -> intro_gen dloc (IntroMustBe id) hto true + | None -> intro_gen dloc (IntroAvoid []) hto true false + | Some id -> intro_gen dloc (IntroMustBe id) hto true false let pf_lookup_hypothesis_as_renamed env ccl = function | AnonHyp n -> pf_lookup_index_as_renamed env ccl n - | NamedHyp id -> pf_lookup_name_as_renamed env ccl id + | NamedHyp id -> pf_lookup_name_as_displayed env ccl id let pf_lookup_hypothesis_as_renamed_gen red h gl = let env = pf_env gl in let rec aux ccl = match pf_lookup_hypothesis_as_renamed env ccl h with | None when red -> - aux - ((fst (Redexpr.reduction_of_red_expr (Red true))) + aux + ((fst (Redexpr.reduction_of_red_expr (Red true))) env (project gl) ccl) | x -> x in @@ -498,7 +539,7 @@ let is_quantified_hypothesis id g = | None -> false let msg_quantified_hypothesis = function - | NamedHyp id -> + | NamedHyp id -> str "quantified hypothesis named " ++ pr_id id | AnonHyp n -> int n ++ str (match n with 1 -> "st" | 2 -> "nd" | _ -> "th") ++ @@ -508,7 +549,7 @@ let depth_of_quantified_hypothesis red h gl = match pf_lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> - errorlabstrm "lookup_quantified_hypothesis" + errorlabstrm "lookup_quantified_hypothesis" (str "No " ++ msg_quantified_hypothesis h ++ strbrk " in current goal" ++ (if red then strbrk " even after head-reduction" else mt ()) ++ @@ -526,12 +567,12 @@ let intros_until_n_wored = intros_until_n_gen false let try_intros_until tac = function | NamedHyp id -> tclTHEN (tclTRY (intros_until_id id)) (tac id) - | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHyp tac) + | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHypId tac) let rec intros_move = function | [] -> tclIDTAC | (hyp,destopt) :: rest -> - tclTHEN (intro_gen dloc (IntroMustBe hyp) destopt false) + tclTHEN (intro_gen dloc (IntroMustBe hyp) destopt false false) (intros_move rest) let dependent_in_decl a (_,c,t) = @@ -543,13 +584,13 @@ let dependent_in_decl a (_,c,t) = or a term with bindings *) let onInductionArg tac = function - | ElimOnConstr (c,lbindc as cbl) -> - if isVar c & lbindc = NoBindings then + | ElimOnConstr (c,lbindc as cbl) -> + if isVar c & lbindc = NoBindings then tclTHEN (tclTRY (intros_until_id (destVar c))) (tac cbl) else tac cbl | ElimOnAnonHyp n -> - tclTHEN (intros_until_n n) (tclLAST_HYP (fun c -> tac (c,NoBindings))) + tclTHEN (intros_until_n n) (onLastHyp (fun c -> tac (c,NoBindings))) | ElimOnIdent (_,id) -> (*Identifier apart because id can be quantified in goal and not typable*) tclTHEN (tclTRY (intros_until_id id)) (tac (mkVar id,NoBindings)) @@ -560,11 +601,11 @@ let onInductionArg tac = function let apply_type hdcty argl gl = refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl - + let apply_term hdc argl gl = refine (applist (hdc,argl)) gl -let bring_hyps hyps = +let bring_hyps hyps = if hyps = [] then Refiner.tclIDTAC else (fun gl -> @@ -577,14 +618,14 @@ let resolve_classes gl = if evd = Evd.empty then tclIDTAC gl else let evd' = Typeclasses.resolve_typeclasses env (Evd.create_evar_defs evd) in - (tclTHEN (tclEVARS (Evd.evars_of evd')) tclNORMEVAR) gl + (tclTHEN (tclEVARS evd') tclNORMEVAR) gl (**************************) (* Cut tactics *) (**************************) let cut c gl = - match kind_of_term (hnf_type_of gl c) with + match kind_of_term (pf_hnf_type_of gl c) with | Sort _ -> let id=next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in let t = mkProd (Anonymous, c, pf_concl gl) in @@ -596,17 +637,37 @@ let cut c gl = let cut_intro t = tclTHENFIRST (cut t) intro -(* cut_replacing échoue si l'hypothèse à remplacer apparaît dans le - but, ou dans une autre hypothèse *) -let cut_replacing id t tac = - tclTHENLAST (internal_cut_rev_replace id t) - (tac (refine_no_check (mkVar id))) +(* [assert_replacing id T tac] adds the subgoals of the proof of [T] + before the current goal + + id:T0 id:T0 id:T + ===== ------> tac(=====) + ==== + G T G + + It fails if the hypothesis to replace appears in the goal or in + another hypothesis. +*) + +let assert_replacing id t tac = tclTHENFIRST (internal_cut_replace id t) tac -let cut_in_parallel l = +(* [cut_replacing id T tac] adds the subgoals of the proof of [T] + after the current goal + + id:T0 id:T id:T0 + ===== ------> ==== + tac(=====) + G G T + + It fails if the hypothesis to replace appears in the goal or in + another hypothesis. +*) + +let cut_replacing id t tac = tclTHENLAST (internal_cut_rev_replace id t) tac + +let cut_in_parallel l = let rec prec = function - | [] -> tclIDTAC + | [] -> tclIDTAC | h::t -> tclTHENFIRST (cut h) (prec t) - in + in prec (List.rev l) let error_uninstantiated_metas t clenv = @@ -614,86 +675,118 @@ let error_uninstantiated_metas t clenv = let id = match na with Name id -> id | _ -> anomaly "unnamed dependent meta" in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".") -let clenv_refine_in with_evars ?(with_classes=true) id clenv gl = +(* For a clenv expressing some lemma [C[?1:T1,...,?n:Tn] : P] and some + goal [G], [clenv_refine_in] returns [n+1] subgoals, the [n] last + ones (resp [n] first ones if [sidecond_first] is [true]) being the + [Ti] and the first one (resp last one) being [G] whose hypothesis + [id] is replaced by P using the proof given by [tac] *) + +let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) id clenv gl = let clenv = clenv_pose_dependent_evars with_evars clenv in - let clenv = - if with_classes then + let clenv = + if with_classes then { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd } else clenv in let new_hyp_typ = clenv_type clenv in - if not with_evars & occur_meta new_hyp_typ then + if not with_evars & occur_meta new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; - let new_hyp_prf = clenv_value clenv in + let new_hyp_prf = clenv_value clenv in tclTHEN - (tclEVARS (evars_of clenv.evd)) - (cut_replacing id new_hyp_typ - (fun x gl -> refine_no_check new_hyp_prf gl)) gl - + (tclEVARS clenv.evd) + ((if sidecond_first then assert_replacing else cut_replacing) + id new_hyp_typ (refine_no_check new_hyp_prf)) gl (********************************************) (* Elimination tactics *) (********************************************) let last_arg c = match kind_of_term c with - | App (f,cl) -> + | App (f,cl) -> array_last cl | _ -> anomaly "last_arg" +let nth_arg i c = + if i = -1 then last_arg c else + match kind_of_term c with + | App (f,cl) -> cl.(i) + | _ -> anomaly "nth_arg" + +let index_of_ind_arg t = + let rec aux i j t = match kind_of_term t with + | Prod (_,t,u) -> + (* heuristic *) + if isInd (fst (decompose_app t)) then aux (Some j) (j+1) u + else aux i (j+1) u + | _ -> match i with + | Some i -> i + | None -> error "Could not find inductive argument of elimination scheme." + in aux None 0 t + let elim_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; + modulo_conv_on_closed_terms = Some full_transparent_state; use_metas_eagerly = true; modulo_delta = empty_transparent_state; + resolve_evars = false; + use_evars_pattern_unification = true; } -let elimination_clause_scheme with_evars allow_K elimclause indclause gl = - let indmv = - (match kind_of_term (last_arg elimclause.templval.rebus) with +let elimination_clause_scheme with_evars allow_K i elimclause indclause gl = + let indmv = + (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" - (str "The type of elimination clause is not well-formed.")) + (str "The type of elimination clause is not well-formed.")) in - let elimclause' = clenv_fchain indmv elimclause indclause in + let elimclause' = clenv_fchain ~flags:elim_flags indmv elimclause indclause in res_pf elimclause' ~with_evars:with_evars ~allow_K:allow_K ~flags:elim_flags gl -(* cast added otherwise tactics Case (n1,n2) generates (?f x y) and - * refine fails *) - -let type_clenv_binding wc (c,t) lbind = - clenv_type (make_clenv_binding wc (c,t) lbind) - -(* - * Elimination tactic with bindings and using an arbitrary - * elimination constant called elimc. This constant should end +(* + * Elimination tactic with bindings and using an arbitrary + * elimination constant called elimc. This constant should end * with a clause (x:I)(P .. ), where P is a bound variable. - * The term c is of type t, which is a product ending with a type - * matching I, lbindc are the expected terms for c arguments + * The term c is of type t, which is a product ending with a type + * matching I, lbindc are the expected terms for c arguments *) -let general_elim_clause elimtac (c,lbindc) (elimc,lbindelimc) gl = +type eliminator = { + elimindex : int option; (* None = find it automatically *) + elimbody : constr with_bindings +} + +let general_elim_clause_gen elimtac indclause elim gl = + let (elimc,lbindelimc) = elim.elimbody in + let elimt = pf_type_of gl elimc in + let i = + match elim.elimindex with None -> index_of_ind_arg elimt | Some i -> i in + let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in + elimtac i elimclause indclause gl + +let general_elim_clause elimtac (c,lbindc) elim gl = let ct = pf_type_of gl c in let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in let indclause = make_clenv_binding gl (c,t) lbindc in - let elimt = pf_type_of gl elimc in - let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in - elimtac elimclause indclause gl + general_elim_clause_gen elimtac indclause elim gl let general_elim with_evars c e ?(allow_K=true) = general_elim_clause (elimination_clause_scheme with_evars allow_K) c e -(* Elimination tactic with bindings but using the default elimination +(* Elimination tactic with bindings but using the default elimination * constant associated with the type. *) let find_eliminator c gl = let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in - lookup_eliminator ind (elimination_sort_of_goal gl) + let c = lookup_eliminator ind (elimination_sort_of_goal gl) in + {elimindex = None; elimbody = (c,NoBindings)} -let default_elim with_evars (c,_ as cx) gl = - general_elim with_evars cx (find_eliminator c gl,NoBindings) gl +let default_elim with_evars (c,_ as cx) gl = + general_elim with_evars cx (find_eliminator c gl) gl let elim_in_context with_evars c = function - | Some elim -> general_elim with_evars c elim ~allow_K:true + | Some elim -> + general_elim with_evars c {elimindex = Some (-1); elimbody = elim} + ~allow_K:true | None -> default_elim with_evars c let elim with_evars (c,lbindc as cx) elim = @@ -723,21 +816,23 @@ let clenv_fchain_in id elim_flags mv elimclause hypclause = (* Set the hypothesis name in the message *) raise (PretypeError (env,NoOccurrenceFound (op,Some id))) -let elimination_in_clause_scheme with_evars id elimclause indclause gl = - let (hypmv,indmv) = - match clenv_independent elimclause with - [k1;k2] -> (k1,k2) - | _ -> errorlabstrm "elimination_clause" +let elimination_in_clause_scheme with_evars id i elimclause indclause gl = + let indmv = destMeta (nth_arg i elimclause.templval.rebus) in + let hypmv = + try match list_remove indmv (clenv_independent elimclause) with + | [a] -> a + | _ -> failwith "" + with Failure _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed.") in - let elimclause' = clenv_fchain indmv elimclause indclause in + let elimclause' = clenv_fchain indmv elimclause indclause in let hyp = mkVar id in let hyp_typ = pf_type_of gl hyp in let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in - let elimclause'' = + let elimclause'' = clenv_fchain_in id elim_flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if eq_constr hyp_typ new_hyp_typ then - errorlabstrm "general_rewrite_in" + errorlabstrm "general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id elimclause'' gl @@ -748,11 +843,14 @@ let general_elim_in with_evars id = let general_case_analysis_in_context with_evars (c,lbindc) gl = let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in - let sort = elimination_sort_of_goal gl in - let case = - if occur_term c (pf_concl gl) then make_case_dep else make_case_gen in - let elim = pf_apply case gl mind sort in - general_elim with_evars (c,lbindc) (elim,NoBindings) gl + let sort = elimination_sort_of_goal gl in + let elim = + if occur_term c (pf_concl gl) then + pf_apply build_case_analysis_scheme gl mind true sort + else + pf_apply build_case_analysis_scheme_default gl mind sort in + general_elim with_evars (c,lbindc) + {elimindex = None; elimbody = (elim,NoBindings)} gl let general_case_analysis with_evars (c,lbindc as cx) = match kind_of_term c with @@ -764,24 +862,60 @@ let general_case_analysis with_evars (c,lbindc as cx) = let simplest_case c = general_case_analysis false (c,NoBindings) -(* Apply a tactic below the products of the conclusion of a lemma *) - -let descend_in_conjunctions with_evars tac exit c gl = +(* Apply a tactic below the products of the conclusion of a lemma *) + +type conjunction_status = + | DefinedRecord of constant option list + | NotADefinedRecordUseScheme of constr + +let make_projection params cstr sign elim i n c = + let elim = match elim with + | NotADefinedRecordUseScheme elim -> + let (na,b,t) = List.nth cstr.cs_args i in + let b = match b with None -> mkRel (i+1) | Some b -> b in + let branch = it_mkLambda_or_LetIn b cstr.cs_args in + if noccur_between 1 (n-i-1) t then + let t = lift (i+1-n) t in + Some (beta_applist (elim,params@[t;branch]),t) + else + None + | DefinedRecord l -> + match List.nth l i with + | Some proj -> + let t = Typeops.type_of_constant (Global.env()) proj in + Some (beta_applist (mkConst proj,params),prod_applist t (params@[c])) + | None -> None + in Option.map (fun (abselim,elimt) -> + let c = beta_applist (abselim,[mkApp (c,extended_rel_vect 0 sign)]) in + (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn elimt sign)) elim + +let descend_in_conjunctions tac exit c gl = try - let (mind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in - match match_with_record (snd (decompose_prod t)) with - | Some _ -> - let n = (mis_constr_nargs mind).(0) in + let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + let sign,ccl = decompose_prod_assum t in + match match_with_tuple ccl with + | Some (_,_,isrec) -> + let n = (mis_constr_nargs ind).(0) in let sort = elimination_sort_of_goal gl in - let elim = pf_apply make_case_gen gl mind sort in - tclTHENLAST - (general_elim with_evars (c,NoBindings) (elim,NoBindings)) - (tclTHENLIST [ - tclDO n intro; - tclLAST_NHYPS n (fun l -> - tclFIRST - (List.map (fun id -> tclTHEN (tac (mkVar id)) (thin l)) l))]) - gl + let id = fresh_id [] (id_of_string "H") gl in + let IndType (indf,_) = pf_apply find_rectype gl ccl in + let params = snd (dest_ind_family indf) in + let cstr = (get_constructors (pf_env gl) indf).(0) in + let elim = + try DefinedRecord (Recordops.lookup_projections ind) + with Not_found -> + let elim = pf_apply build_case_analysis_scheme gl ind false sort in + NotADefinedRecordUseScheme elim in + tclFIRST + (list_tabulate (fun i gl -> + match make_projection params cstr sign elim i n c with + | None -> tclFAIL 0 (mt()) gl + | Some (p,pt) -> + tclTHENS + (internal_cut id pt) + [refine_no_check p; + tclTHEN (tac (not isrec) (mkVar id)) (thin [id])] gl) n) + gl | None -> raise Exit with RefinerError _|UserError _|Exit -> exit () @@ -790,93 +924,62 @@ let descend_in_conjunctions with_evars tac exit c gl = (* Resolution tactics *) (****************************************************) -(* Resolution with missing arguments *) - -let check_evars sigma evm gl = - let origsigma = gl.sigma in - let rest = - Evd.fold (fun ev evi acc -> - if not (Evd.mem origsigma ev) && not (Evd.is_defined sigma ev) - then Evd.add acc ev evi else acc) - evm Evd.empty - in - if rest <> Evd.empty then - errorlabstrm "apply" (str"Uninstantiated existential variables: " ++ - fnl () ++ pr_evar_map rest) - -let general_apply with_delta with_destruct with_evars (c,lbind) gl0 = - let flags = +let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 = + let flags = if with_delta then default_unify_flags else default_no_delta_unify_flags in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) let concl_nprod = nb_prod (pf_concl gl0) in - let evm, c = c in - let rec try_main_apply c gl = + let rec try_main_apply with_destruct c gl = let thm_ty0 = nf_betaiota (project gl) (pf_type_of gl c) in let try_apply thm_ty nprod = let n = nb_prod thm_ty - nprod in if n<0 then error "Applied theorem has not enough premisses."; let clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in - let res = Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl in - if not with_evars then check_evars (fst res).sigma evm gl0; - res + Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl in try try_apply thm_ty0 concl_nprod with PretypeError _|RefinerError _|UserError _|Failure _ as exn -> let rec try_red_apply thm_ty = - try + try (* Try to head-reduce the conclusion of the theorem *) let red_thm = try_red_product (pf_env gl) (project gl) thm_ty in try try_apply red_thm concl_nprod with PretypeError _|RefinerError _|UserError _|Failure _ -> try_red_apply red_thm - with Redelimination -> + with Redelimination -> (* Last chance: if the head is a variable, apply may try second order unification *) try if concl_nprod <> 0 then try_apply thm_ty 0 else raise Exit with PretypeError _|RefinerError _|UserError _|Failure _|Exit -> if with_destruct then - descend_in_conjunctions with_evars - try_main_apply (fun _ -> raise exn) c gl + descend_in_conjunctions + try_main_apply (fun _ -> Stdpp.raise_with_loc loc exn) c gl else - raise exn - in try_red_apply thm_ty0 + Stdpp.raise_with_loc loc exn + in try_red_apply thm_ty0 in - if evm = Evd.empty then try_main_apply c gl0 - else - tclTHEN (tclEVARS (Evd.merge gl0.sigma evm)) (try_main_apply c) gl0 + try_main_apply with_destruct c gl0 -let rec apply_with_ebindings_gen b e = function - | [] -> - tclIDTAC - | [cb] -> - general_apply b b e cb - | cb::cbl -> - tclTHENLAST (general_apply b b e cb) (apply_with_ebindings_gen b e cbl) +let rec apply_with_bindings_gen b e = function + | [] -> tclIDTAC + | [cb] -> general_apply b b e cb + | cb::cbl -> + tclTHENLAST (general_apply b b e cb) (apply_with_bindings_gen b e cbl) -let apply_with_ebindings cb = apply_with_ebindings_gen false false [cb] -let eapply_with_ebindings cb = apply_with_ebindings_gen false true [cb] +let apply_with_bindings cb = apply_with_bindings_gen false false [dloc,cb] -let apply_with_bindings (c,bl) = - apply_with_ebindings (inj_open c,inj_ebindings bl) +let eapply_with_bindings cb = apply_with_bindings_gen false true [dloc,cb] -let eapply_with_bindings (c,bl) = - apply_with_ebindings_gen false true [inj_open c,inj_ebindings bl] +let apply c = apply_with_bindings_gen false false [dloc,(c,NoBindings)] -let apply c = - apply_with_ebindings (inj_open c,NoBindings) +let eapply c = apply_with_bindings_gen false true [dloc,(c,NoBindings)] -let apply_list = function +let apply_list = function | c::l -> apply_with_bindings (c,ImplicitBindings l) | _ -> assert false -(* Resolution with no reduction on the type (used ?) *) - -let apply_without_reduce c gl = - let clause = mk_clenv_type_of gl c in - res_pf clause gl - (* [apply_in hyp c] replaces hyp : forall y1, ti -> t hyp : rho(u) @@ -909,29 +1012,23 @@ let apply_in_once_main flags innerclause (d,lbind) gl = try progress_with_clause flags innerclause clause with err -> try aux (clenv_push_prod clause) - with NotExtensibleClause -> raise err in + with NotExtensibleClause -> raise err in aux (make_clenv_binding gl (d,thm) lbind) -let apply_in_once with_delta with_destruct with_evars id ((sigma,d),lbind) gl0 = - let flags = +let apply_in_once sidecond_first with_delta with_destruct with_evars id + (loc,(d,lbind)) gl0 = + let flags = if with_delta then default_unify_flags else default_no_delta_unify_flags in let t' = pf_get_hyp_typ gl0 id in let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in - let rec aux c gl = + let rec aux with_destruct c gl = try let clause = apply_in_once_main flags innerclause (c,lbind) gl in - let res = clenv_refine_in with_evars id clause gl in - if not with_evars then check_evars (fst res).sigma sigma gl0; - res + clenv_refine_in ~sidecond_first with_evars id clause gl with exn when with_destruct -> - descend_in_conjunctions true aux (fun _ -> raise exn) c gl + descend_in_conjunctions aux (fun _ -> raise exn) c gl in - if sigma = Evd.empty then aux d gl0 - else - tclTHEN (tclEVARS (Evd.merge gl0.sigma sigma)) (aux d) gl0 - - - + aux with_destruct d gl0 (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A @@ -951,7 +1048,7 @@ let apply_in_once with_delta with_destruct with_evars id ((sigma,d),lbind) gl0 = *) let cut_and_apply c gl = - let goal_constr = pf_concl gl in + let goal_constr = pf_concl gl in match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> tclTHENLAST @@ -966,14 +1063,14 @@ let cut_and_apply c gl = let exact_check c gl = let concl = (pf_concl gl) in let ct = pf_type_of gl c in - if pf_conv_x_leq gl ct concl then - refine_no_check c gl - else + if pf_conv_x_leq gl ct concl then + refine_no_check c gl + else error "Not an exact proof." let exact_no_check = refine_no_check -let vm_cast_no_check c gl = +let vm_cast_no_check c gl = let concl = pf_concl gl in refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl @@ -981,16 +1078,16 @@ let vm_cast_no_check c gl = let exact_proof c gl = (* on experimente la synthese d'ise dans exact *) let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) - in refine_no_check c gl + in refine_no_check c gl let (assumption : tactic) = fun gl -> - let concl = pf_concl gl in + let concl = pf_concl gl in let hyps = pf_hyps gl in let rec arec only_eq = function - | [] -> + | [] -> if only_eq then arec false hyps else error "No such assumption." - | (id,c,t)::rest -> - if (only_eq & eq_constr t concl) + | (id,c,t)::rest -> + if (only_eq & eq_constr t concl) or (not only_eq & pf_conv_x_leq gl t concl) then refine_no_check (mkVar id) gl else arec only_eq rest @@ -1002,9 +1099,9 @@ let (assumption : tactic) = fun gl -> (*****************************************************************) (* This tactic enables the user to remove hypotheses from the signature. - * Some care is taken to prevent him from removing variables that are - * subsequently used in other hypotheses or in the conclusion of the - * goal. *) + * Some care is taken to prevent him from removing variables that are + * subsequently used in other hypotheses or in the conclusion of the + * goal. *) let clear ids = (* avant seul dyn_clear n'echouait pas en [] *) if ids=[] then tclIDTAC else thin ids @@ -1020,7 +1117,7 @@ let clear_wildcards ids = (error_clear_dependency (pf_env gl) (id_of_string "_") err)) ids -(* Takes a list of booleans, and introduces all the variables +(* Takes a list of booleans, and introduces all the variables * quantified in the goal which are associated with a value * true in the boolean list. *) @@ -1029,46 +1126,42 @@ let rec intros_clearing = function | (false::tl) -> tclTHEN intro (intros_clearing tl) | (true::tl) -> tclTHENLIST - [ intro; onLastHyp (fun id -> clear [id]); intros_clearing tl] + [ intro; onLastHypId (fun id -> clear [id]); intros_clearing tl] (* Modifying/Adding an hypothesis *) let specialize mopt (c,lbind) g = - let evars, term = - if lbind = NoBindings then None, c - else + let term = + if lbind = NoBindings then c + else let clause = make_clenv_binding g (c,pf_type_of g c) lbind in let clause = clenv_unify_meta_types clause in - let (thd,tstack) = - whd_stack (evars_of clause.evd) (clenv_value clause) in + let (thd,tstack) = whd_stack clause.evd (clenv_value clause) in let nargs = List.length tstack in - let tstack = match mopt with - | Some m -> + let tstack = match mopt with + | Some m -> if m < nargs then list_firstn m tstack else tstack - | None -> - let rec chk = function + | None -> + let rec chk = function | [] -> [] | t::l -> if occur_meta t then [] else t :: chk l in chk tstack - in - let term = applist(thd,tstack) in + in + let term = applist(thd,List.map (nf_evar clause.evd) tstack) in if occur_meta term then errorlabstrm "" (str "Cannot infer an instance for " ++ pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); - Some (evars_of clause.evd), term + term in - tclTHEN - (match evars with Some e -> tclEVARS e | _ -> tclIDTAC) - (match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with + match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with | Var id when List.mem id (pf_ids_of_hyps g) -> tclTHENFIRST (fun g -> internal_cut_replace id (pf_type_of g term) g) - (exact_no_check term) - | _ -> tclTHENLAST + (exact_no_check term) g + | _ -> tclTHENLAST (fun g -> cut (pf_type_of g term) g) - (exact_no_check term)) - g + (exact_no_check term) g (* Keeping only a few hypotheses *) @@ -1091,7 +1184,7 @@ let keep hyps gl = let check_number_of_constructors expctdnumopt i nconstr = if i=0 then error "The constructors are numbered starting from 1."; - begin match expctdnumopt with + begin match expctdnumopt with | Some n when n <> nconstr -> error ("Not an inductive goal with "^ string_of_int n^plural n " constructor"^".") @@ -1100,19 +1193,19 @@ let check_number_of_constructors expctdnumopt i nconstr = if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind gl = - let cl = pf_concl gl in - let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in + let cl = pf_concl gl in + let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in let nconstr = Array.length (snd (Global.lookup_inductive mind)).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; let cons = mkConstruct (ith_constructor_of_inductive mind i) in - let apply_tac = general_apply true false with_evars (inj_open cons,lbind) in - (tclTHENLIST + let apply_tac = general_apply true false with_evars (dloc,(cons,lbind)) in + (tclTHENLIST [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl -let one_constructor i = constructor_tac false None i +let one_constructor i lbind = constructor_tac false None i lbind -(* Try to apply the constructor of the inductive definition followed by +(* Try to apply the constructor of the inductive definition followed by a tactic t given as an argument. Should be generalize in Constructor (Fun c : I -> tactic) *) @@ -1125,22 +1218,22 @@ let any_constructor with_evars tacopt gl = if nconstr = 0 then error "The type has no constructors."; tclFIRST (List.map - (fun i -> tclTHEN (constructor_tac with_evars None i NoBindings) t) + (fun i -> tclTHEN (constructor_tac with_evars None i NoBindings) t) (interval 1 nconstr)) gl -let left_with_ebindings with_evars = constructor_tac with_evars (Some 2) 1 -let right_with_ebindings with_evars = constructor_tac with_evars (Some 2) 2 -let split_with_ebindings with_evars = constructor_tac with_evars (Some 1) 1 - -let left l = left_with_ebindings false (inj_ebindings l) -let simplest_left = left NoBindings +let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 +let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2 +let split_with_bindings with_evars l = + tclMAP (constructor_tac with_evars (Some 1) 1) l -let right l = right_with_ebindings false (inj_ebindings l) -let simplest_right = right NoBindings +let left = left_with_bindings false +let simplest_left = left NoBindings -let split l = split_with_ebindings false (inj_ebindings l) -let simplest_split = split NoBindings +let right = right_with_bindings false +let simplest_right = right NoBindings +let split = constructor_tac false (Some 1) 1 +let simplest_split = split NoBindings (*****************************) (* Decomposing introductions *) @@ -1184,7 +1277,7 @@ let intro_or_and_pattern loc b ll l' tac id gl = let rewrite_hyp l2r id gl = let rew_on l2r = - !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) in + !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) in let clear_var_and_eq c = tclTRY (tclTHEN (clear [id]) (tclTRY (clear [destVar c]))) in let t = pf_whd_betadeltaiota gl (pf_type_of gl (mkVar id)) in @@ -1192,15 +1285,15 @@ let rewrite_hyp l2r id gl = match match_with_equality_type t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r & isVar lhs & not (occur_var (pf_env gl) (destVar lhs) rhs) then - tclTHEN (rew_on l2r allClauses) (clear_var_and_eq lhs) gl + tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq lhs) gl else if not l2r & isVar rhs & not (occur_var (pf_env gl) (destVar rhs) lhs) then - tclTHEN (rew_on l2r allClauses) (clear_var_and_eq rhs) gl + tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq rhs) gl else tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl | Some (hdcncl,[c]) -> let l2r = not l2r in (* equality of the form eq_true *) if isVar c then - tclTHEN (rew_on l2r allClauses) (clear_var_and_eq c) gl + tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq c) gl else tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl | _ -> @@ -1209,9 +1302,9 @@ let rewrite_hyp l2r id gl = let rec explicit_intro_names = function | (_, IntroIdentifier id) :: l -> id :: explicit_intro_names l -| (_, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _)) :: l -> - explicit_intro_names l -| (_, IntroOrAndPattern ll) :: l' -> +| (_, (IntroWildcard | IntroAnonymous | IntroFresh _ + | IntroRewrite _ | IntroForthcoming _)) :: l -> explicit_intro_names l +| (_, IntroOrAndPattern ll) :: l' -> List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll) | [] -> [] @@ -1222,37 +1315,44 @@ let rec explicit_intro_names = function the tactic, for the hyps to clear *) let rec intros_patterns b avoid thin destopt = function | (loc, IntroWildcard) :: l -> - tclTHEN - (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true) - (onLastHyp (fun id -> + tclTHEN + (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) + no_move true false) + (onLastHypId (fun id -> tclORELSE (tclTHEN (clear [id]) (intros_patterns b avoid thin destopt l)) (intros_patterns b avoid ((loc,id)::thin) destopt l))) | (loc, IntroIdentifier id) :: l -> tclTHEN - (intro_gen loc (IntroMustBe id) destopt true) + (intro_gen loc (IntroMustBe id) destopt true false) (intros_patterns b avoid thin destopt l) | (loc, IntroAnonymous) :: l -> tclTHEN (intro_gen loc (IntroAvoid (avoid@explicit_intro_names l)) - destopt true) + destopt true false) (intros_patterns b avoid thin destopt l) | (loc, IntroFresh id) :: l -> tclTHEN (intro_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l)) - destopt true) + destopt true false) + (intros_patterns b avoid thin destopt l) + | (loc, IntroForthcoming onlydeps) :: l -> + tclTHEN + (intro_forthcoming_gen loc (IntroAvoid (avoid@explicit_intro_names l)) + destopt onlydeps) (intros_patterns b avoid thin destopt l) | (loc, IntroOrAndPattern ll) :: l' -> tclTHEN introf - (onLastHyp + (onLastHypId (intro_or_and_pattern loc b ll l' (intros_patterns b avoid thin destopt))) | (loc, IntroRewrite l2r) :: l -> - tclTHEN - (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true) - (onLastHyp (fun id -> - tclTHEN + tclTHEN + (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) + no_move true false) + (onLastHypId (fun id -> + tclTHENLAST (* Skip the side conditions of the rewriting step *) (rewrite_hyp l2r id) (intros_patterns b avoid thin destopt l))) | [] -> clear_wildcards thin @@ -1261,7 +1361,7 @@ let intros_pattern = intros_patterns false [] [] let intro_pattern destopt pat = intros_patterns false [] [] destopt [dloc,pat] -let intro_patterns = function +let intro_patterns = function | [] -> tclREPEAT intro | l -> intros_pattern no_move l @@ -1278,13 +1378,15 @@ let prepare_intros s ipat gl = match ipat with | IntroAnonymous -> make_id s gl, tclIDTAC | IntroFresh id -> fresh_id [] id gl, tclIDTAC | IntroWildcard -> let id = make_id s gl in id, clear_wildcards [dloc,id] - | IntroRewrite l2r -> + | IntroRewrite l2r -> let id = make_id s gl in - id, !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allClauses + id, !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl | IntroOrAndPattern ll -> make_id s gl, - onLastHyp - (intro_or_and_pattern loc true ll [] + onLastHypId + (intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move)) + | IntroForthcoming _ -> user_err_loc + (loc,"",str "Introduction pattern for one hypothesis expected") let ipat_of_name = function | Anonymous -> None @@ -1292,12 +1394,12 @@ let ipat_of_name = function let allow_replace c gl = function (* A rather arbitrary condition... *) | Some (_, IntroIdentifier id) -> - fst (decompose_app (snd (decompose_lam_assum c))) = mkVar id + fst (decompose_app ((strip_lam_assum c))) = mkVar id | _ -> false let assert_as first ipat c gl = - match kind_of_term (hnf_type_of gl c) with + match kind_of_term (pf_hnf_type_of gl c) with | Sort s -> let id,tac = prepare_intros s ipat gl in let repl = allow_replace c gl ipat in @@ -1311,23 +1413,44 @@ let assert_tac na = assert_as true (ipat_of_name na) (* apply in as *) let as_tac id ipat = match ipat with - | Some (loc,IntroRewrite l2r) -> - !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allClauses + | Some (loc,IntroRewrite l2r) -> + !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl | Some (loc,IntroOrAndPattern ll) -> intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move) id | Some (loc, - (IntroIdentifier _ | IntroAnonymous | IntroFresh _ | IntroWildcard)) -> + (IntroIdentifier _ | IntroAnonymous | IntroFresh _ | + IntroWildcard | IntroForthcoming _)) -> user_err_loc (loc,"", str "Disjunctive/conjunctive pattern expected") | None -> tclIDTAC -let general_apply_in with_delta with_destruct with_evars id lemmas ipat gl = - tclTHEN - (tclMAP (apply_in_once with_delta with_destruct with_evars id) lemmas) - (as_tac id ipat) - gl +let tclMAPLAST tacfun l = + List.fold_right (fun x -> tclTHENLAST (tacfun x)) l tclIDTAC + +let tclMAPFIRST tacfun l = + List.fold_right (fun x -> tclTHENFIRST (tacfun x)) l tclIDTAC + +let general_apply_in sidecond_first with_delta with_destruct with_evars + id lemmas ipat = + if sidecond_first then + (* Skip the side conditions of the applied lemma *) + tclTHENLAST + (tclMAPLAST + (apply_in_once sidecond_first with_delta with_destruct with_evars id) + lemmas) + (as_tac id ipat) + else + tclTHENFIRST + (tclMAPFIRST + (apply_in_once sidecond_first with_delta with_destruct with_evars id) + lemmas) + (as_tac id ipat) -let apply_in simple with_evars = general_apply_in simple simple with_evars +let apply_in simple with_evars id lemmas ipat = + general_apply_in false simple simple with_evars id lemmas ipat + +let simple_apply_in id c = + general_apply_in false false false false id [dloc,(c,NoBindings)] None (**************************) (* Generalize tactics *) @@ -1336,38 +1459,38 @@ let apply_in simple with_evars = general_apply_in simple simple with_evars let generalized_name c t ids cl = function | Name id as na -> if List.mem id ids then - errorlabstrm "" (pr_id id ++ str " is already used"); + errorlabstrm "" (pr_id id ++ str " is already used"); na - | Anonymous -> + | Anonymous -> match kind_of_term c with | Var id -> (* Keep the name even if not occurring: may be used by intros later *) Name id | _ -> if noccurn 1 cl then Anonymous else - (* On ne s'etait pas casse la tete : on avait pris pour nom de + (* On ne s'etait pas casse la tete : on avait pris pour nom de variable la premiere lettre du type, meme si "c" avait ete une constante dont on aurait pu prendre directement le nom *) named_hd (Global.env()) t Anonymous -let generalize_goal gl i ((occs,c),na) cl = +let generalize_goal gl i ((occs,c,b),na) cl = let t = pf_type_of gl c in let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in let cl' = subst_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in - mkProd (na,t,cl') + mkProd_or_LetIn (na,b,t) cl' -let generalize_dep c gl = +let generalize_dep ?(with_let=false) c gl = let env = pf_env gl in let sign = pf_hyps gl in let init_ids = ids_of_named_context (Global.named_context()) in let rec seek d toquant = if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant - or dependent_in_decl c d then + or dependent_in_decl c d then d::toquant - else + else toquant in let to_quantify = Sign.fold_named_context seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in @@ -1380,39 +1503,58 @@ let generalize_dep c gl = | _ -> tothin in let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in - let cl'' = generalize_goal gl 0 ((all_occurrences,c),Anonymous) cl' in + let body = + if with_let then + match kind_of_term c with + | Var id -> pi2 (pf_get_hyp gl id) + | _ -> None + else None + in + let cl'' = generalize_goal gl 0 ((all_occurrences,c,body),Anonymous) cl' in let args = Array.to_list (instance_from_named_context to_quantify_rev) in tclTHEN - (apply_type cl'' (c::args)) + (apply_type cl'' (if body = None then c::args else args)) (thin (List.rev tothin')) gl -let generalize_gen lconstr gl = +let generalize_gen_let lconstr gl = let newcl = list_fold_right_i (generalize_goal gl) 0 lconstr (pf_concl gl) in - apply_type newcl (List.map (fun ((_,c),_) -> c) lconstr) gl + apply_type newcl (list_map_filter (fun ((_,c,b),_) -> + if b = None then Some c else None) lconstr) gl +let generalize_gen lconstr = + generalize_gen_let (List.map (fun ((occs,c),na) -> + (occs,c,None),na) lconstr) + let generalize l = - generalize_gen (List.map (fun c -> ((all_occurrences,c),Anonymous)) l) + generalize_gen_let (List.map (fun c -> ((all_occurrences,c,None),Anonymous)) l) + +let pf_get_hyp_val gl id = + let (_, b, _) = pf_get_hyp gl id in + b let revert hyps gl = - tclTHEN (generalize (List.map mkVar hyps)) (clear hyps) gl + let lconstr = List.map (fun id -> + ((all_occurrences, mkVar id, pf_get_hyp_val gl id), Anonymous)) + hyps + in tclTHEN (generalize_gen_let lconstr) (clear hyps) gl (* Faudra-t-il une version avec plusieurs args de generalize_dep ? -Cela peut-être troublant de faire "Generalize Dependent H n" dans -"n:nat; H:n=n |- P(n)" et d'échouer parce que H a disparu après la -généralisation dépendante par n. +Cela peut-être troublant de faire "Generalize Dependent H n" dans +"n:nat; H:n=n |- P(n)" et d'échouer parce que H a disparu après la +généralisation dépendante par n. let quantify lconstr = - List.fold_right + List.fold_right (fun com tac -> tclTHEN tac (tactic_com generalize_dep c)) lconstr tclIDTAC *) -(* A dependent cut rule à la sequent calculus +(* A dependent cut rule à la sequent calculus ------------------------------------------ - Sera simplifiable le jour où il y aura un let in primitif dans constr + Sera simplifiable le jour où il y aura un let in primitif dans constr [letin_tac b na c (occ_hyp,occ_ccl) gl] transforms [...x1:T1(c),...,x2:T2(c),... |- G(c)] into @@ -1434,6 +1576,10 @@ let quantify lconstr = the left of each x1, ...). *) +let out_arg = function + | ArgVar _ -> anomaly "Unevaluated or_var variable" + | ArgArg x -> x + let occurrences_of_hyp id cls = let rec hyp_occ = function [] -> None @@ -1466,13 +1612,13 @@ let letin_abstract id c occs gl = if not (in_every_hyp occs) then raise (RefinerError (DoesNotOccurIn (c,hyp))) else raise Not_found - else + else (subst1_named_decl (mkVar id) newdecl, true) - with Not_found -> + with Not_found -> (d,List.exists (fun ((id,_,_),dep) -> dep && occur_var_in_decl env id d) ctxt) in d'::ctxt - in + in let ctxt' = fold_named_context compute_dependency env ~init:[] in let compute_marks ((depdecls,marks as accu),lhyp) ((hyp,_,_) as d,b) = if b then ((d::depdecls,(hyp,lhyp)::marks), lhyp) @@ -1490,7 +1636,7 @@ let letin_tac with_eq name c occs gl = if name = Anonymous then fresh_id [] x gl else if not (mem_named_context x (pf_hyps gl)) then x else error ("The variable "^(string_of_id x)^" is already declared") in - let (depdecls,marks,ccl)= letin_abstract id c occs gl in + let (depdecls,marks,ccl)= letin_abstract id c occs gl in let t = pf_type_of gl c in let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in let args = Array.to_list (instance_from_named_context depdecls) in @@ -1515,11 +1661,11 @@ let letin_abstract id c (occs,check_occs) gl = | Some occ -> let newdecl = subst_term_occ_decl occ c d in if occ = (all_occurrences,InHyp) & d = newdecl then - if check_occs & not (in_every_hyp occs) + if check_occs & not (in_every_hyp occs) then raise (RefinerError (DoesNotOccurIn (c,hyp))) else depdecls - else - (subst1_named_decl (mkVar id) newdecl)::depdecls in + else + (subst1_named_decl (mkVar id) newdecl)::depdecls in let depdecls = fold_named_context compute_dependency env ~init:[] in let ccl = match occurrences_of_goal occs with | None -> pf_concl gl @@ -1534,7 +1680,7 @@ let letin_tac_gen with_eq name c ty occs gl = if name = Anonymous then fresh_id [] x gl else if not (mem_named_context x (pf_hyps gl)) then x else error ("The variable "^(string_of_id x)^" is already declared.") in - let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in + let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in let t = match ty with Some t -> t | None -> pf_type_of gl c in let newcl,eq_tac = match with_eq with | Some (lr,(loc,ido)) -> @@ -1549,13 +1695,13 @@ let letin_tac_gen with_eq name c ty occs gl = let refl = applist (eqdata.refl, [t;mkVar id]) in mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)), tclTHEN - (intro_gen loc (IntroMustBe heq) lastlhyp true) + (intro_gen loc (IntroMustBe heq) lastlhyp true false) (thin_body [heq;id]) | None -> mkNamedLetIn id c t ccl, tclIDTAC in tclTHENLIST [ convert_concl_no_check newcl DEFAULTcast; - intro_gen dloc (IntroMustBe id) lastlhyp true; + intro_gen dloc (IntroMustBe id) lastlhyp true false; eq_tac; tclMAP convert_hyp_no_check depdecls ] gl @@ -1565,10 +1711,10 @@ let letin_tac with_eq name c ty occs = (* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *) let forward usetac ipat c gl = match usetac with - | None -> + | None -> let t = pf_type_of gl c in tclTHENFIRST (assert_as true ipat t) (exact_no_check c) gl - | Some tac -> + | Some tac -> tclTHENFIRST (assert_as true ipat c) tac gl let pose_proof na c = forward None (ipat_of_name na) c @@ -1588,7 +1734,7 @@ let unfold_body x gl = | _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") in let aft = afterHyp x gl in - let hl = List.fold_right (fun (y,yval,_) cl -> (([],y),InHyp) :: cl) aft [] in + 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 @@ -1609,7 +1755,7 @@ let unfold_all x gl = (* * A "natural" induction tactic - * + * - [H0:T0, ..., Hi:Ti, hyp0:P->I(args), Hi+1:Ti+1, ..., Hn:Tn |-G] is the goal - [hyp0] is the induction hypothesis - we extract from [args] the variables which are not rigid parameters @@ -1641,31 +1787,36 @@ let unfold_all x gl = let check_unused_names names = if names <> [] & Flags.is_verbose () then - msg_warning + msg_warning (str"Unused introduction " ++ str (plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc pr_intro_pattern names) let rec first_name_buggy avoid gl (loc,pat) = match pat with | IntroOrAndPattern [] -> no_move - | IntroOrAndPattern ([]::l) -> + | IntroOrAndPattern ([]::l) -> first_name_buggy avoid gl (loc,IntroOrAndPattern l) | IntroOrAndPattern ((p::_)::_) -> first_name_buggy avoid gl p | IntroWildcard -> no_move | IntroRewrite _ -> no_move | IntroIdentifier id -> MoveAfter id - | IntroAnonymous | IntroFresh _ -> (* buggy *) no_move + | IntroAnonymous | IntroFresh _ | IntroForthcoming _ -> (* buggy *) no_move -let consume_pattern avoid id gl = function +let rec consume_pattern avoid id isdep gl = function | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), []) | (loc,IntroAnonymous)::names -> let avoid = avoid@explicit_intro_names names in ((loc,IntroIdentifier (fresh_id avoid id gl)), names) + | (loc,IntroForthcoming true)::names when not isdep -> + consume_pattern avoid id isdep gl names + | (loc,IntroForthcoming _)::names as fullpat -> + let avoid = avoid@explicit_intro_names names in + ((loc,IntroIdentifier (fresh_id avoid id gl)), fullpat) | (loc,IntroFresh id')::names -> let avoid = avoid@explicit_intro_names names in ((loc,IntroIdentifier (fresh_id avoid id' gl)), names) | pat::names -> (pat,names) -let re_intro_dependent_hypotheses tophyp (lstatus,rstatus) = +let re_intro_dependent_hypotheses (lstatus,rstatus) tophyp = let newlstatus = (* if some IH has taken place at the top of hyps *) List.map (function (hyp,MoveToEnd true) -> (hyp,tophyp) | x -> x) lstatus in @@ -1675,20 +1826,29 @@ let re_intro_dependent_hypotheses tophyp (lstatus,rstatus) = let update destopt tophyp = if destopt = no_move then tophyp else destopt +let safe_dest_intros_patterns avoid dest pat gl = + try intros_patterns true avoid [] dest pat gl + with UserError ("move_hyp",_) -> + (* May happen if the lemma has dependent arguments that has resolved + only after cook_sign is called, e.g. as in + "dec:forall x, {x=0}+{x<>0}; a:A |- if dec a then True else False" + for argument a of dec which will be found only lately *) + intros_patterns true avoid [] no_move pat gl + type elim_arg_kind = RecArg | IndArg | OtherArg -let induct_discharge statuslists destopt avoid' (avoid,ra) names gl = +let induct_discharge destopt avoid' tac (avoid,ra) names gl = let avoid = avoid @ avoid' in let rec peel_tac ra names tophyp gl = match ra with - | (RecArg,recvarname) :: - (IndArg,hyprecname) :: ra' -> + | (RecArg,deprec,recvarname) :: + (IndArg,depind,hyprecname) :: ra' -> let recpat,names = match names with | [loc,IntroIdentifier id as pat] -> let id' = next_ident_away (add_prefix "IH" id) avoid in (pat, [dloc, IntroIdentifier id']) - | _ -> consume_pattern avoid recvarname gl names in - let hyprec,names = consume_pattern avoid hyprecname gl names in + | _ -> consume_pattern avoid recvarname deprec gl names in + let hyprec,names = consume_pattern avoid hyprecname depind gl names in (* IH stays at top: we need to update tophyp *) (* This is buggy for intro-or-patterns with different first hypnames *) (* Would need to pass peel_tac as a continuation of intros_patterns *) @@ -1697,43 +1857,43 @@ let induct_discharge statuslists destopt avoid' (avoid,ra) names gl = if tophyp=no_move then first_name_buggy avoid gl hyprec else tophyp in tclTHENLIST - [ intros_patterns true avoid [] (update destopt tophyp) [recpat]; - intros_patterns true avoid [] no_move [hyprec]; + [ safe_dest_intros_patterns avoid (update destopt tophyp) [recpat]; + safe_dest_intros_patterns avoid no_move [hyprec]; peel_tac ra' names newtophyp] gl - | (IndArg,hyprecname) :: ra' -> + | (IndArg,dep,hyprecname) :: ra' -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) - let pat,names = consume_pattern avoid hyprecname gl names in - tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat]) + let pat,names = consume_pattern avoid hyprecname dep gl names in + tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat]) (peel_tac ra' names tophyp) gl - | (RecArg,recvarname) :: ra' -> - let pat,names = consume_pattern avoid recvarname gl names in - tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat]) + | (RecArg,dep,recvarname) :: ra' -> + let pat,names = consume_pattern avoid recvarname dep gl names in + tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat]) (peel_tac ra' names tophyp) gl - | (OtherArg,_) :: ra' -> + | (OtherArg,_,_) :: ra' -> let pat,names = match names with | [] -> (dloc, IntroAnonymous), [] | pat::names -> pat,names in - tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat]) + tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat]) (peel_tac ra' names tophyp) gl | [] -> check_unused_names names; - re_intro_dependent_hypotheses tophyp statuslists gl + tac tophyp gl in peel_tac ra names no_move gl -(* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas - s'embêter à regarder si un letin_tac ne fait pas des +(* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas + s'embêter à regarder si un letin_tac ne fait pas des substitutions aussi sur l'argument voisin *) -(* Marche pas... faut prendre en compte l'occurrence précise... *) +(* Marche pas... faut prendre en compte l'occurrence précise... *) -let atomize_param_of_ind (indref,nparams) hyp0 gl = +let atomize_param_of_ind (indref,nparams,_) hyp0 gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in let prods, indtyp = decompose_prod typ0 in let argl = snd (decompose_app indtyp) in let params = list_firstn nparams argl in - (* le gl est important pour ne pas préévaluer *) + (* le gl est important pour ne pas préévaluer *) let rec atomize_one i avoid gl = if i<>nparams then let tmptyp0 = pf_get_hyp_typ gl hyp0 in @@ -1748,16 +1908,16 @@ let atomize_param_of_ind (indref,nparams) hyp0 gl = | Var id -> let x = fresh_id [] id gl in tclTHEN - (letin_tac None (Name x) (mkVar id) None allClauses) + (letin_tac None (Name x) (mkVar id) None allHypsAndConcl) (atomize_one (i-1) ((mkVar x)::avoid)) gl | _ -> let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in let x = fresh_id [] id gl in tclTHEN - (letin_tac None (Name x) c None allClauses) + (letin_tac None (Name x) c None allHypsAndConcl) (atomize_one (i-1) ((mkVar x)::avoid)) gl - else + else tclIDTAC gl in atomize_one (List.length argl) params gl @@ -1775,7 +1935,7 @@ let find_atomic_param_of_ind nparams indtyp = | _ -> () done; Idset.elements !indvars; - + (* [cook_sign] builds the lists [indhyps] of hyps that must be erased, the lists of hyps to be generalize [(hdeps,tdeps)] on the @@ -1794,7 +1954,7 @@ let find_atomic_param_of_ind nparams indtyp = To summarize, the situation looks like this Goal(n,x) -| H6:(Q n); x:A; H5:True; H4:(le O n); H3:(P n); H2:True; n:nat - Left Right + Left Right Induction hypothesis is H4 ([hyp0]) Variable parameters of (le O n) is the singleton list with "n" ([indvars]) @@ -1828,7 +1988,7 @@ let find_atomic_param_of_ind nparams indtyp = would have posed no problem. But for uniformity, we decided to use the right hyp for all hyps on the right of H4. - Others solutions are welcome + Others solutions are welcome PC 9 fev 06: Adapted to accept multi argument principle with no main arg hyp. hyp0 is now optional, meaning that it is possible @@ -1858,15 +2018,15 @@ let cook_sign hyp0_opt indvars env = let before = ref true in let seek_deps env (hyp,_,_ as decl) rhyp = if hyp = hyp0 then begin - before:=false; + before:=false; (* If there was no main induction hypotheses, then hyp is one of indvars too, so add it to indhyps. *) - (if hyp0_opt=None then indhyps := hyp::!indhyps); + (if hyp0_opt=None then indhyps := hyp::!indhyps); MoveToEnd false (* fake value *) end else if List.mem hyp indvars then begin (* warning: hyp can still occur after induction *) (* e.g. if the goal (t hyp hyp0) with other occs of hyp in t *) - indhyps := hyp::!indhyps; + indhyps := hyp::!indhyps; rhyp end else if inhyps <> [] && List.mem hyp inhyps || inhyps = [] && @@ -1874,9 +2034,9 @@ let cook_sign hyp0_opt indvars env = List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps) then begin decldeps := decl::!decldeps; - if !before then + if !before then rstatus := (hyp,rhyp)::!rstatus - else + else ldeps := hyp::!ldeps; (* status computed in 2nd phase *) MoveBefore hyp end else @@ -1892,8 +2052,8 @@ let cook_sign hyp0_opt indvars env = end else if List.mem hyp !indhyps then lhyp else MoveAfter hyp in - try - let _ = + try + let _ = fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in raise (Shunt (MoveToEnd true)) (* ?? FIXME *) with Shunt lhyp0 -> @@ -1904,7 +2064,7 @@ let cook_sign hyp0_opt indvars env = (* The general form of an induction principle is the following: - + forall prm1 prm2 ... prmp, (induction parameters) forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates) branch1, branch2, ... , branchr, (branches of the principle) @@ -1913,7 +2073,7 @@ let cook_sign hyp0_opt indvars env = -> (Qi x1...xni HI (f prm1...prmp x1...xni)).(conclusion) ^^ ^^^^^^^^^^^^^^^^^^^^^^^^ optional optional argument added if - even if HI principle generated by functional + even if HI principle generated by functional present above induction, only if HI does not exist [indarg] [farg] @@ -1926,31 +2086,33 @@ let cook_sign hyp0_opt indvars env = (* [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) -type elim_scheme = { - elimc: constr with_ebindings option; +type elim_scheme = { + elimc: constr with_bindings option; elimt: types; indref: global_reference option; + index: int; (* index of the elimination type in the scheme *) params: rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (* number of parameters *) predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) npredicates: int; (* Number of predicates *) branches: rel_context; (* branchr,...,branch1 *) - nbranches: int; (* Number of branches *) + nbranches: int; (* Number of branches *) args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (* number of arguments *) - indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) + indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) - concl: types; (* Qi x1...xni HI (f...), HI and (f...) + concl: types; (* Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) } -let empty_scheme = - { +let empty_scheme = + { elimc = None; elimt = mkProp; indref = None; + index = -1; params = []; nparams = 0; predicates = []; @@ -1965,19 +2127,6 @@ let empty_scheme = farg_in_concl = false; } - -(* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the - hypothesis on which the induction is made *) -let induction_tac with_evars (varname,lbind) typ scheme gl = - let elimc,lbindelimc = - match scheme.elimc with | Some x -> x | None -> error "No definition of the principle." in - let elimt = scheme.elimt in - let indclause = make_clenv_binding gl (mkVar varname,typ) lbind in - let elimclause = - make_clenv_binding gl - (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in - elimination_clause_scheme with_evars true elimclause indclause gl - let make_base n id = if n=0 or n=1 then id else @@ -1988,15 +2137,15 @@ let make_base n id = (* Builds two different names from an optional inductive type and a number, also deals with a list of names to avoid. If the inductive type is None, then hyprecname is IHi where i is a number. *) -let make_up_names n ind_opt cname = +let make_up_names n ind_opt cname = let is_hyp = atompart_of_id cname = "H" in let base = string_of_id (make_base n cname) in let ind_prefix = "IH" in - let base_ind = - if is_hyp then + let base_ind = + if is_hyp then match ind_opt with | None -> id_of_string ind_prefix - | Some ind_id -> add_prefix ind_prefix (Nametab.id_of_global ind_id) + | Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id) else add_prefix ind_prefix cname in let hyprecname = make_base n base_ind in let avoid = @@ -2014,53 +2163,44 @@ let make_up_names n ind_opt cname = let is_indhyp p n t = let l, c = decompose_prod t in - let c,_ = decompose_app c in + let c,_ = decompose_app c in let p = p + List.length l in match kind_of_term c with | Rel k when p < k & k <= p + n -> true | _ -> false -let chop_context n l = +let chop_context n l = let rec chop_aux acc = function | n, (_,Some _,_ as h :: t) -> chop_aux (h::acc) (n, t) | 0, l2 -> (List.rev acc, l2) | n, (h::t) -> chop_aux (h::acc) (n-1, t) | _, [] -> anomaly "chop_context" - in + in chop_aux [] (n,l) let error_ind_scheme s = let s = if s <> "" then s^" " else s in error ("Cannot recognize "^s^"an induction scheme.") +let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq +let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl) + +let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") +let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") + let mkEq t x y = - mkApp (build_coq_eq (), [| t; x; y |]) + mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |]) let mkRefl t x = - mkApp ((build_coq_eq_data ()).refl, [| t; x |]) + mkApp (Lazy.force coq_eq_refl, [| refresh_universes_strict t; x |]) let mkHEq t x u y = - mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq", - [| t; x; u; y |]) + mkApp (Lazy.force coq_heq, + [| refresh_universes_strict t; x; refresh_universes_strict u; y |]) let mkHRefl t x = - mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl", - [| t; x |]) - -(* let id = lazy (coq_constant "mkHEq" ["Init";"Datatypes"] "id") *) - -(* let mkHEq t x u y = *) -(* let ty = new_Type () in *) -(* mkApp (coq_constant "mkHEq" ["Logic";"EqdepFacts"] "eq_dep", *) -(* [| ty; mkApp (Lazy.force id, [|ty|]); t; x; u; y |]) *) - -(* let mkHRefl t x = *) -(* let ty = new_Type () in *) -(* mkApp (coq_constant "mkHEq" ["Logic";"EqdepFacts"] "eq_dep_intro", *) -(* [| ty; mkApp (Lazy.force id, [|ty|]); t; x |]) *) - -let mkCoe a x p px y eq = - mkApp (Option.get (build_coq_eq_data ()).rect, [| a; x; p; px; y; eq |]) + mkApp (Lazy.force coq_heq_refl, + [| refresh_universes_strict t; x |]) let lift_togethern n l = let l', _ = @@ -2069,161 +2209,279 @@ let lift_togethern n l = (lift n x :: acc, succ n)) l ([], n) in l' - + let lift_together l = lift_togethern 0 l let lift_list l = List.map (lift 1) l -let ids_of_constr vars c = - let rec aux vars c = +let ids_of_constr ?(all=false) vars c = + let rec aux vars c = match kind_of_term c with - | Var id -> if List.mem id vars then vars else id :: vars + | Var id -> Idset.add id vars | App (f, args) -> (match kind_of_term f with - | Construct (ind,_) + | Construct (ind,_) | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in - array_fold_left_from mib.Declarations.mind_nparams + array_fold_left_from + (if all then 0 else mib.Declarations.mind_nparams) aux vars args | _ -> fold_constr aux vars c) | _ -> fold_constr aux vars c in aux vars c + +let decompose_indapp f args = + match kind_of_term f with + | Construct (ind,_) + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + let first = mib.Declarations.mind_nparams_rec in + let pars, args = array_chop first args in + mkApp (f, pars), args + | _ -> f, args + +let mk_term_eq env sigma ty t ty' t' = + if Reductionops.is_conv env sigma ty ty' then + mkEq ty t t', mkRefl ty' t' + else + mkHEq ty t ty' t', mkHRefl ty' t' -let make_abstract_generalize gl id concl dep ctx c eqs args refls = +let make_abstract_generalize gl id concl dep ctx body c eqs args refls = let meta = Evarutil.new_meta() in - let term, typ = mkVar id, pf_get_hyp_typ gl id in let eqslen = List.length eqs in + let term, typ = mkVar id, pf_get_hyp_typ gl id in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) - let abshypeq = - if dep then - mkProd (Anonymous, mkHEq (lift 1 c) (mkRel 1) typ term, lift 1 concl) - else concl + let abshypeq, abshypt = + if dep then + let eq, refl = mk_term_eq (push_rel_context ctx (pf_env gl)) (project gl) (lift 1 c) (mkRel 1) typ term in + mkProd (Anonymous, eq, lift 1 concl), [| refl |] + else concl, [||] in (* Abstract by equalitites *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) let abseqs = it_mkProd_or_LetIn ~init:(lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in (* Abstract by the "generalized" hypothesis. *) - let genarg = mkProd (Name id, c, abseqs) in + let genarg = mkProd_or_LetIn (Name id, body, c) abseqs in (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn ~init:genarg ctx in (* The goal will become this product. *) - let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in + let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in (* Then apply to the original instanciated hyp. *) - let instc = mkApp (instc, [| mkVar id |]) in + let instc = Option.cata (fun _ -> instc) (mkApp (instc, [| mkVar id |])) body in (* Apply the reflexivity proofs on the indices. *) let appeqs = mkApp (instc, Array.of_list refls) in (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) - let newc = if dep then mkApp (appeqs, [| mkHRefl typ term |]) else appeqs in - newc + mkApp (appeqs, abshypt) -let abstract_args gl id = - let c = pf_get_hyp_typ gl id in +let deps_of_var id env = + Environ.fold_named_context + (fun _ (n,b,t) (acc : Idset.t) -> + if Option.cata (occur_var env id) false b || occur_var env id t then + Idset.add n acc + else acc) + env ~init:Idset.empty + +let idset_of_list = + List.fold_left (fun s x -> Idset.add x s) Idset.empty + +let hyps_of_vars env sign nogen hyps = + if Idset.is_empty hyps then [] + else + let (_,lh) = + Sign.fold_named_context_reverse + (fun (hs,hl) (x,_,_ as d) -> + if Idset.mem x nogen then (hs,hl) + else if Idset.mem x hs then (hs,x::hl) + else + let xvars = global_vars_set_of_decl env d in + if not (Idset.equal (Idset.diff xvars hs) Idset.empty) then + (Idset.add x hs, x :: hl) + else (hs, hl)) + ~init:(hyps,[]) + sign + in lh + +exception Seen + +let linear vars args = + let seen = ref vars in + try + Array.iter (fun i -> + let rels = ids_of_constr ~all:true Idset.empty i in + let seen' = + Idset.fold (fun id acc -> + if Idset.mem id acc then raise Seen + else Idset.add id acc) + rels !seen + in seen := seen') + args; + true + with Seen -> false + +let abstract_args gl generalize_vars dep id defined f args = let sigma = project gl in let env = pf_env gl in let concl = pf_concl gl in - let dep = dependent (mkVar id) concl in + let dep = dep || dependent (mkVar id) concl in let avoid = ref [] in - let get_id name = - let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> id_of_string "gen_x") gl in + let get_id name = + let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> id_of_string "gen_x") gl in avoid := id :: !avoid; id in - match kind_of_term c with - App (f, args) -> - (* Build application generalized w.r.t. the argument plus the necessary eqs. - From env |- c : forall G, T and args : G we build - (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize) - - eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) - *) - let aux (prod, ctx, ctxenv, c, args, eqs, refls, vars, env) arg = - let (name, _, ty), arity = - let rel, c = Reductionops.decomp_n_prod env sigma 1 prod in - List.hd rel, c + (* Build application generalized w.r.t. the argument plus the necessary eqs. + From env |- c : forall G, T and args : G we build + (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize) + + eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) + *) + let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = + let (name, _, ty), arity = + let rel, c = Reductionops.splay_prod_n env sigma 1 prod in + List.hd rel, c + in + let argty = pf_type_of gl arg in + let argty = refresh_universes_strict argty in + let lenctx = List.length ctx in + let liftargty = lift lenctx argty in + let leq = constr_cmp Reduction.CUMUL liftargty ty in + match kind_of_term arg with + | Var id when leq && not (Idset.mem id nongenvars) -> + (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, + Idset.add id nongenvars, Idset.remove id vars, env) + | _ -> + let name = get_id name in + let decl = (Name name, None, ty) in + let ctx = decl :: ctx in + let c' = mkApp (lift 1 c, [|mkRel 1|]) in + let args = arg :: args in + let liftarg = lift (List.length ctx) arg in + let eq, refl = + if leq then + mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl (lift (-lenctx) ty) arg + else + mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg in - let argty = pf_type_of gl arg in - let liftargty = lift (List.length ctx) argty in - let convertible = Reductionops.is_conv_leq ctxenv sigma liftargty ty in - match kind_of_term arg with - | Var _ | Rel _ | Ind _ when convertible -> - (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, vars, env) - | _ -> - let name = get_id name in - let decl = (Name name, None, ty) in - let ctx = decl :: ctx in - let c' = mkApp (lift 1 c, [|mkRel 1|]) in - let args = arg :: args in - let liftarg = lift (List.length ctx) arg in - let eq, refl = - if convertible then - mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl argty arg - else - mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg - in - let eqs = eq :: lift_list eqs in - let refls = refl :: refls in - let vars = ids_of_constr vars arg in - (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, vars, env) - in - let f, args = - match kind_of_term f with - | Construct (ind,_) - | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in - let first = mib.Declarations.mind_nparams in - let pars, args = array_chop first args in - mkApp (f, pars), args - | _ -> f, args - in - let arity, ctx, ctxenv, c', args, eqs, refls, vars, env = - Array.fold_left aux (pf_type_of gl f,[],env,f,[],[],[],[],env) args - in - let args, refls = List.rev args, List.rev refls in - Some (make_abstract_generalize gl id concl dep ctx c' eqs args refls, - dep, succ (List.length ctx), vars) - | _ -> None - -let abstract_generalize id ?(generalize_vars=true) gl = + let eqs = eq :: lift_list eqs in + let refls = refl :: refls in + let argvars = ids_of_constr vars arg in + (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, + nongenvars, Idset.union argvars vars, env) + in + let f', args' = decompose_indapp f args in + let dogen, f', args' = + let parvars = ids_of_constr ~all:true Idset.empty f' in + if not (linear parvars args') then true, f, args + else + match array_find_i (fun i x -> not (isVar x)) args' with + | None -> false, f', args' + | Some nonvar -> + let before, after = array_chop nonvar args' in + true, mkApp (f', before), after + in + if dogen then + let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = + Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Idset.empty,Idset.empty,env) args' + in + let args, refls = List.rev args, List.rev refls in + let vars = + if generalize_vars then + let nogen = Idset.add id nogen in + hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars + else [] + in + let body, c' = if defined then Some c', Retyping.get_type_of ctxenv Evd.empty c' else None, c' in + Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls, + dep, succ (List.length ctx), vars) + else None + +let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id gl = Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; - let oldid = pf_get_new_id id gl in - let newc = abstract_args gl id in - match newc with + let f, args, def, id, oldid = + let oldid = pf_get_new_id id gl in + let (_, b, t) = pf_get_hyp gl id in + match b with + | None -> let f, args = decompose_app t in + f, args, false, id, oldid + | Some t -> + let f, args = decompose_app t in + f, args, true, id, oldid + in + if args = [] then tclIDTAC gl + else + let args = Array.of_list args in + let newc = abstract_args gl generalize_vars force_dep id def f args in + match newc with | None -> tclIDTAC gl | Some (newc, dep, n, vars) -> let tac = if dep then tclTHENLIST [refine newc; rename_hyp [(id, oldid)]; tclDO n intro; - generalize_dep (mkVar oldid)] + generalize_dep ~with_let:true (mkVar oldid)] else tclTHENLIST [refine newc; clear [id]; tclDO n intro] in - if generalize_vars then tclTHEN tac - (tclFIRST [revert (List.rev vars) ; - tclMAP (fun id -> tclTRY (generalize_dep (mkVar id))) vars]) gl - else tac gl - -let dependent_pattern c gl = - let cty = pf_type_of gl c in - let deps = - match kind_of_term cty with - | App (f, args) -> Array.to_list args - | _ -> [] - in - let varname c = match kind_of_term c with - | Var id -> id - | _ -> id_of_string (hdchar (pf_env gl) c) - in - let mklambda ty (c, id, cty) = - let conclvar = subst_term_occ all_occurrences c ty in - mkNamedLambda id cty conclvar + if vars = [] then tac gl + else tclTHEN tac + (fun gl -> tclFIRST [revert vars ; + tclMAP (fun id -> + tclTRY (generalize_dep ~with_let:true (mkVar id))) vars] gl) gl + +let specialize_eqs id gl = + let env = pf_env gl in + let ty = pf_get_hyp_typ gl id in + let evars = ref (create_evar_defs (project gl)) in + let unif env evars c1 c2 = Evarconv.e_conv env evars c2 c1 in + let rec aux in_eqs ctx acc ty = + match kind_of_term ty with + | Prod (na, t, b) -> + (match kind_of_term t with + | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) -> + let c = if noccur_between 1 (List.length ctx) x then y else x in + let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in + let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in + if unif (push_rel_context ctx env) evars pt t then + aux true ctx (mkApp (acc, [| p |])) (subst1 p b) + else acc, in_eqs, ctx, ty + | App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) -> + let eqt, c = if noccur_between 1 (List.length ctx) x then eqty', y else eqty, x in + let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in + let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in + if unif (push_rel_context ctx env) evars pt t then + aux true ctx (mkApp (acc, [| p |])) (subst1 p b) + else acc, in_eqs, ctx, ty + | _ -> + if in_eqs then acc, in_eqs, ctx, ty + else + let e = e_new_evar evars (push_rel_context ctx env) t in + aux false ((na, Some e, t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) + | t -> acc, in_eqs, ctx, ty + in + let acc, worked, ctx, ty = aux false [] (mkVar id) ty in + let ctx' = nf_rel_context_evar !evars ctx in + let ctx'' = List.map (fun (n,b,t as decl) -> + match b with + | Some k when isEvar k -> (n,None,t) + | b -> decl) ctx' in - let subst = (c, varname c, cty) :: List.rev_map (fun c -> (c, varname c, pf_type_of gl c)) deps in - let concllda = List.fold_left mklambda (pf_concl gl) subst in - let conclapp = applistc concllda (List.rev_map pi1 subst) in - convert_concl_no_check conclapp DEFAULTcast gl + let ty' = it_mkProd_or_LetIn ty ctx'' in + let acc' = it_mkLambda_or_LetIn acc ctx'' in + let ty' = Tacred.whd_simpl env !evars ty' + and acc' = Tacred.whd_simpl env !evars acc' in + let ty' = Evarutil.nf_evar !evars ty' in + if worked then + tclTHENFIRST (Tacmach.internal_cut true id ty') + (exact_no_check (refresh_universes_strict acc')) gl + else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl -let occur_rel n c = + +let specialize_eqs id gl = + if try ignore(clear [id] gl); false with _ -> true then + tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl + else specialize_eqs id gl + +let occur_rel n c = let res = not (noccurn n c) in res @@ -2266,19 +2524,19 @@ let cut_list n l = (* This function splits the products of the induction scheme [elimt] into four - parts: + parts: - branches, easily detectable (they are not referred by rels in the subterm) - what was found before branches (acc1) that is: parameters and predicates - what was found after branches (acc3) that is: args and indarg if any if there is no branch, we try to fill in acc3 with args/indargs. We also return the conclusion. *) -let decompose_paramspred_branch_args elimt = +let decompose_paramspred_branch_args elimt = let rec cut_noccur elimt acc2 : rel_context * rel_context * types = match kind_of_term elimt with - | Prod(nme,tpe,elimt') -> - let hd_tpe,_ = decompose_app (snd (decompose_prod_assum tpe)) in - if not (occur_rel 1 elimt') && isRel hd_tpe + | Prod(nme,tpe,elimt') -> + let hd_tpe,_ = decompose_app ((strip_prod_assum tpe)) in + if not (occur_rel 1 elimt') && isRel hd_tpe then cut_noccur elimt' ((nme,None,tpe)::acc2) else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt @@ -2297,7 +2555,7 @@ let decompose_paramspred_branch_args elimt = we must find the predicate of the conclusion to separate params_pred from args. We suppose there is only one predicate here. *) if List.length acc2 <> 0 then acc1, acc2 , acc3, ccl - else + else let hyps,ccl = decompose_prod_assum elimt in let hd_ccl_pred,_ = decompose_app ccl in match kind_of_term hd_ccl_pred with @@ -2315,7 +2573,7 @@ let exchange_hd_app subst_hd t = eliminator by modifying their scheme_info, then rebuild the eliminator type, then prove it (with tactics). *) let rebuild_elimtype_from_scheme (scheme:elim_scheme): types = - let hiconcl = + let hiconcl = match scheme.indarg with | None -> scheme.concl | Some x -> mkProd_or_LetIn x scheme.concl in @@ -2333,8 +2591,8 @@ exception NoLastArgCcl first separate branches. We obtain branches, hyps before (params + preds), hyps after (args <+ indarg if present>) and conclusion. Then we proceed as follows: - - - separate parameters and predicates in params_preds. For that we build: + + - separate parameters and predicates in params_preds. For that we build: forall (x1:Ti_1)(xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY x1...xni HI/farg ^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^ optional opt @@ -2346,28 +2604,28 @@ exception NoLastArgCcl - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *) let compute_elim_sig ?elimc elimt = - let params_preds,branches,args_indargs,conclusion = + let params_preds,branches,args_indargs,conclusion = decompose_paramspred_branch_args elimt in - + let ccl = exchange_hd_app (mkVar (id_of_string "__QI_DUMMY__")) conclusion in - let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in + let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in let nparams = Intset.cardinal (free_rels concl_with_args) in let preds,params = cut_list (List.length params_preds - nparams) params_preds in - + (* A first approximation, further analysis will tweak it *) let res = ref { empty_scheme with (* This fields are ok: *) elimc = elimc; elimt = elimt; concl = conclusion; - predicates = preds; npredicates = List.length preds; - branches = branches; nbranches = List.length branches; + predicates = preds; npredicates = List.length preds; + branches = branches; nbranches = List.length branches; farg_in_concl = isApp ccl && isApp (last_arg ccl); - params = params; nparams = nparams; + params = params; nparams = nparams; (* all other fields are unsure at this point. Including these:*) args = args_indargs; nargs = List.length args_indargs; } in - try + try (* Order of tests below is important. Each of them exits if successful. *) (* 1- First see if (f x...) is in the conclusion. *) - if !res.farg_in_concl + if !res.farg_in_concl then begin res := { !res with indarg = None; @@ -2375,19 +2633,19 @@ let compute_elim_sig ?elimc elimt = raise Exit end; (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *) - if !res.nargs=0 then raise Exit; + if !res.nargs=0 then raise Exit; (* 3- Look at last arg: is it the indarg? *) ignore ( match List.hd args_indargs with | hiname,Some _,hi -> error_ind_scheme "" - | hiname,None,hi -> + | hiname,None,hi -> let hi_ind, hi_args = decompose_app hi in let hi_is_ind = (* hi est d'un type globalisable *) match kind_of_term hi_ind with - | Ind (mind,_) -> true - | Var _ -> true - | Const _ -> true - | Construct _ -> true + | Ind (mind,_) -> true + | Var _ -> true + | Const _ -> true + | Construct _ -> true | _ -> false in let hi_args_enough = (* hi a le bon nbre d'arguments *) List.length hi_args = List.length params + !res.nargs -1 in @@ -2405,78 +2663,75 @@ let compute_elim_sig ?elimc elimt = match !res.indarg with | None -> !res (* No indref *) | Some ( _,Some _,_) -> error_ind_scheme "" - | Some ( _,None,ind) -> + | Some ( _,None,ind) -> let indhd,indargs = decompose_app ind in try {!res with indref = Some (global_of_constr indhd) } with _ -> error "Cannot find the inductive type of the inductive scheme.";; -(* Check that the elimination scheme has a form similar to the - elimination schemes built by Coq. Schemes may have the standard - form computed from an inductive type OR (feb. 2006) a non standard - form. That is: with no main induction argument and with an optional - extra final argument of the form (f x y ...) in the conclusion. In - the non standard case, naming of generated hypos is slightly - different. *) -let compute_elim_signature elimc elimt names_info ind_type_guess = - let scheme = compute_elim_sig ~elimc:elimc elimt in +let compute_scheme_signature scheme names_info ind_type_guess = let f,l = decompose_app scheme.concl in - (* Vérifier que les arguments de Qi sont bien les xi. *) + (* Vérifier que les arguments de Qi sont bien les xi. *) match scheme.indarg with | Some (_,Some _,_) -> error "Strange letin, cannot recognize an induction scheme." | None -> (* Non standard scheme *) - let is_pred n c = + let is_pred n c = let hd = fst (decompose_app c) in match kind_of_term hd with | Rel q when n < q & q <= n+scheme.npredicates -> IndArg | _ when hd = ind_type_guess & not scheme.farg_in_concl -> RecArg - | _ -> OtherArg in - let rec check_branch p c = + | _ -> OtherArg in + let rec check_branch p c = match kind_of_term c with - | Prod (_,t,c) -> is_pred p t :: check_branch (p+1) c - | LetIn (_,_,_,c) -> OtherArg :: check_branch (p+1) c + | Prod (_,t,c) -> + (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c + | LetIn (_,_,_,c) -> + (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c | _ when is_pred p c = IndArg -> [] - | _ -> raise Exit in - let rec find_branches p lbrch = + | _ -> raise Exit in + let rec find_branches p lbrch = match lbrch with | (_,None,t)::brs -> (try let lchck_brch = check_branch p t in - let n = List.fold_left - (fun n b -> if b=RecArg then n+1 else n) 0 lchck_brch in - let recvarname, hyprecname, avoid = + let n = List.fold_left + (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in + let recvarname, hyprecname, avoid = make_up_names n scheme.indref names_info in - let namesign = - List.map (fun b -> (b,if b=IndArg then hyprecname else recvarname)) + let namesign = + List.map (fun (b,dep) -> + (b,dep,if b=IndArg then hyprecname else recvarname)) lchck_brch in (avoid,namesign) :: find_branches (p+1) brs with Exit-> error_ind_scheme "the branches of") | (_,Some _,_)::_ -> error_ind_scheme "the branches of" | [] -> [] in - let indsign = Array.of_list (find_branches 0 (List.rev scheme.branches)) in - indsign,scheme - + Array.of_list (find_branches 0 (List.rev scheme.branches)) + | Some ( _,None,ind) -> (* Standard scheme from an inductive type *) let indhd,indargs = decompose_app ind in - let is_pred n c = + let is_pred n c = let hd = fst (decompose_app c) in match kind_of_term hd with | Rel q when n < q & q <= n+scheme.npredicates -> IndArg | _ when hd = indhd -> RecArg | _ -> OtherArg in let rec check_branch p c = match kind_of_term c with - | Prod (_,t,c) -> is_pred p t :: check_branch (p+1) c - | LetIn (_,_,_,c) -> OtherArg :: check_branch (p+1) c + | Prod (_,t,c) -> + (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c + | LetIn (_,_,_,c) -> + (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c | _ when is_pred p c = IndArg -> [] - | _ -> raise Exit in + | _ -> raise Exit in let rec find_branches p lbrch = match lbrch with | (_,None,t)::brs -> (try let lchck_brch = check_branch p t in - let n = List.fold_left - (fun n b -> if b=RecArg then n+1 else n) 0 lchck_brch in - let recvarname, hyprecname, avoid = + let n = List.fold_left + (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in + let recvarname, hyprecname, avoid = make_up_names n scheme.indref names_info in - let namesign = - List.map (fun b -> (b,if b=IndArg then hyprecname else recvarname)) + let namesign = + List.map (fun (b,dep) -> + (b,dep,if b=IndArg then hyprecname else recvarname)) lchck_brch in (avoid,namesign) :: find_branches (p+1) brs with Exit -> error_ind_scheme "the branches of") @@ -2485,67 +2740,126 @@ let compute_elim_signature elimc elimt names_info ind_type_guess = (* Check again conclusion *) let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in - let ind_is_ok = - list_lastn scheme.nargs indargs + let ind_is_ok = + list_lastn scheme.nargs indargs = extended_rel_list 0 scheme.args in if not (ccl_arg_ok & ind_is_ok) then error_ind_scheme "the conclusion of"; - [] + [] in - let indsign = Array.of_list (find_branches 0 (List.rev scheme.branches)) in - indsign,scheme + Array.of_list (find_branches 0 (List.rev scheme.branches)) +(* Check that the elimination scheme has a form similar to the + elimination schemes built by Coq. Schemes may have the standard + form computed from an inductive type OR (feb. 2006) a non standard + form. That is: with no main induction argument and with an optional + extra final argument of the form (f x y ...) in the conclusion. In + the non standard case, naming of generated hypos is slightly + different. *) +let compute_elim_signature ((elimc,elimt),ind_type_guess) names_info = + let scheme = compute_elim_sig ~elimc:elimc elimt in + compute_scheme_signature scheme names_info ind_type_guess, scheme -let find_elim_signature isrec elim hyp0 gl = +let guess_elim isrec hyp0 gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in - let (elimc,elimt),ind = match elim with + let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in + let s = elimination_sort_of_goal gl in + let elimc = + if isrec then lookup_eliminator mind s + else + if use_dependent_propositions_elimination () && + dependent_no_evar (mkVar hyp0) (pf_concl gl) + then + pf_apply build_case_analysis_scheme gl mind true s + else + pf_apply build_case_analysis_scheme_default gl mind s in + let elimt = pf_type_of gl elimc in + ((elimc, NoBindings), elimt), mkInd mind + +let given_elim hyp0 (elimc,lbind as e) gl = + let tmptyp0 = pf_get_hyp_typ gl hyp0 in + let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in + (e, pf_type_of gl elimc), ind_type_guess + +let find_elim isrec elim hyp0 gl = + match elim with + | None -> guess_elim isrec hyp0 gl + | Some e -> given_elim hyp0 e gl + +type scheme_signature = + (identifier list * (elim_arg_kind * bool * identifier) list) array + +type eliminator_source = + | ElimUsing of (eliminator * types) * scheme_signature + | ElimOver of bool * identifier + +let find_induction_type isrec elim hyp0 gl = + let scheme,elim = + match elim with | None -> - let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in - let s = elimination_sort_of_goal gl in - let elimc = - if isrec then lookup_eliminator mind s - else pf_apply make_case_gen gl mind s in - let elimt = pf_type_of gl elimc in - ((elimc, NoBindings), elimt), mkInd mind - | Some (elimc,lbind as e) -> - let ind_type_guess,_ = decompose_app (snd (decompose_prod tmptyp0)) in - (e, pf_type_of gl elimc), ind_type_guess in - let indsign,elim_scheme = - compute_elim_signature elimc elimt hyp0 ind in - (indsign,elim_scheme) + let (elimc,elimt),_ = guess_elim isrec hyp0 gl in + let scheme = compute_elim_sig ~elimc elimt in + (* We drop the scheme waiting to know if it is dependent *) + scheme, ElimOver (isrec,hyp0) + | Some e -> + let (elimc,elimt),ind_guess = given_elim hyp0 e gl in + let scheme = compute_elim_sig ~elimc elimt in + if scheme.indarg = None then error "Cannot find induction type"; + let indsign = compute_scheme_signature scheme hyp0 ind_guess in + let elim = ({elimindex = Some(-1); elimbody = elimc},elimt) in + scheme, ElimUsing (elim,indsign) in + Option.get scheme.indref,scheme.nparams, elim +let find_elim_signature isrec elim hyp0 gl = + compute_elim_signature (find_elim isrec elim hyp0 gl) hyp0 + +let is_functional_induction elim gl = + match elim with + | Some elimc -> + let scheme = compute_elim_sig ~elimc (pf_type_of gl (fst elimc)) in + (* The test is not safe: with non-functional induction on non-standard + induction scheme, this may fail *) + scheme.indarg = None + | None -> + false + +(* Wait the last moment to guess the eliminator so as to know if we + need a dependent one or not *) + +let get_eliminator elim gl = match elim with + | ElimUsing (elim,indsign) -> + (* bugged, should be computed *) true, elim, indsign + | ElimOver (isrec,id) -> + let (elimc,elimt),_ as elims = guess_elim isrec id gl in + isrec, ({elimindex = None; elimbody = elimc}, elimt), + fst (compute_elim_signature elims id) (* Instantiate all meta variables of elimclause using lid, some elts of lid are parameters (first ones), the other are arguments. Returns the clause obtained. *) -let recolle_clenv scheme lid elimclause gl = +let recolle_clenv nparams lid elimclause gl = let _,arr = destApp elimclause.templval.rebus in - let lindmv = + let lindmv = Array.map - (fun x -> + (fun x -> match kind_of_term x with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" (str "The type of the elimination clause is not well-formed.")) arr in let nmv = Array.length lindmv in - let lidparams,lidargs = cut_list (scheme.nparams) lid in + let lidparams,lidargs = cut_list nparams lid in let nidargs = List.length lidargs in (* parameters correspond to first elts of lid. *) - let clauses_params = + let clauses_params = list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i)) 0 lidparams in (* arguments correspond to last elts of lid. *) - let clauses_args = - list_map_i + let clauses_args = + list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i)) 0 lidargs in - let clause_indarg = - match scheme.indarg with - | None -> [] - | Some (x,_,typx) -> [] - in - let clauses = clauses_params@clauses_args@clause_indarg in + let clauses = clauses_params@clauses_args in (* iteration of clenv_fchain with all infos we have. *) List.fold_right (fun e acc -> @@ -2563,119 +2877,129 @@ let recolle_clenv scheme lid elimclause gl = (elimc ?i ?j ?k...?l). This solves partly meta variables (and may produce new ones). Then refine with the resulting term with holes. *) -let induction_tac_felim with_evars indvars scheme gl = - let elimt = scheme.elimt in - let elimc,lbindelimc = - match scheme.elimc with | Some x -> x | None -> error "No definition of the principle." in +let induction_tac_felim with_evars indvars nparams elim gl = + let {elimbody=(elimc,lbindelimc)},elimt = elim in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimclause = make_clenv_binding gl (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in (* elimclause' is built from elimclause by instanciating all args and params. *) - let elimclause' = recolle_clenv scheme indvars elimclause gl in + let elimclause' = recolle_clenv nparams indvars elimclause gl in (* one last resolution (useless?) *) let resolved = clenv_unique_resolver true elimclause' gl in clenv_refine with_evars resolved gl -let apply_induction_in_context isrec hyp0 indsign indvars names induct_tac gl = +(* Apply induction "in place" replacing the hypothesis on which + induction applies with the induction hypotheses *) + +let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names tac gl = + let isrec, elim, indsign = get_eliminator elim gl in + let names = compute_induction_names (Array.length indsign) names in + (if isrec then tclTHENFIRSTn else tclTHENLASTn) + (tclTHEN (induct_tac elim) (tclTRY (thin indhyps))) + (array_map2 (induct_discharge destopt avoid tac) indsign names) gl + +(* Apply induction "in place" taking into account dependent + hypotheses from the context *) + +let apply_induction_in_context hyp0 elim indvars names induct_tac gl = let env = pf_env gl in - let statlists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in - let deps = List.map (fun (id,c,t)-> (id,c,refresh_universes_strict t)) deps in + let statuslists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in + let deps = List.map (on_pi3 refresh_universes_strict) deps in let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in - let names = compute_induction_names (Array.length indsign) names in let dephyps = List.map (fun (id,_,_) -> id) deps in let deps_cstr = List.fold_left (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in tclTHENLIST - [ + [ (* Generalize dependent hyps (but not args) *) if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr; (* clear dependent hyps *) thin dephyps; (* side-conditions in elim (resp case) schemes come last (resp first) *) - (if isrec then tclTHENFIRSTn else tclTHENLASTn) - (tclTHEN induct_tac (tclTRY (thin (List.rev indhyps)))) - (array_map2 - (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names) + apply_induction_with_discharge + induct_tac elim (List.rev indhyps) lhyp0 (List.rev dephyps) names + (re_intro_dependent_hypotheses statuslists) ] gl (* Induction with several induction arguments, main differences with induction_from_context is that there is no main induction argument, - so we chose one to be the positioning reference. On the other hand, + so we choose one to be the positioning reference. On the other hand, all args and params must be given, so we help a bit the unifier by making the "pattern" by hand before calling induction_tac_felim FIXME: REUNIF AVEC induction_tac_felim? *) -let induction_from_context_l isrec with_evars elim_info lid names gl = +let induction_from_context_l with_evars elim_info lid names gl = let indsign,scheme = elim_info in (* number of all args, counting farg and indarg if present. *) let nargs_indarg_farg = scheme.nargs - + (if scheme.farg_in_concl then 1 else 0) + + (if scheme.farg_in_concl then 1 else 0) + (if scheme.indarg <> None then 1 else 0) in (* Number of given induction args must be exact. *) - if List.length lid <> nargs_indarg_farg + scheme.nparams then + if List.length lid <> nargs_indarg_farg + scheme.nparams then error "Not the right number of arguments given to induction scheme."; (* hyp0 is used for re-introducing hyps at the right place afterward. We chose the first element of the list of variables on which to induct. It is probably the first of them appearing in the context. *) - let hyp0,indvars,lid_params = + let hyp0,indvars,lid_params = match lid with | [] -> anomaly "induction_from_context_l" - | e::l -> + | e::l -> let nargs_without_first = nargs_indarg_farg - 1 in let ivs,lp = cut_list nargs_without_first l in e, ivs, lp in (* terms to patternify we must patternify indarg or farg if present in concl *) - let lid_in_pattern = + let lid_in_pattern = if scheme.indarg <> None & not scheme.indarg_in_concl then List.rev indvars else List.rev (hyp0::indvars) in let lidcstr = List.map (fun x -> mkVar x) lid_in_pattern in let realindvars = (* hyp0 is a real induction arg if it is not the farg in the conclusion of the induction scheme *) List.rev ((if scheme.farg_in_concl then indvars else hyp0::indvars) @ lid_params) in - let induct_tac = tclTHENLIST [ + let induct_tac elim = tclTHENLIST [ (* pattern to make the predicate appear. *) reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl; (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all possible holes using arguments given by the user (but the functional one). *) (* FIXME: Tester ca avec un principe dependant et non-dependant *) - induction_tac_felim with_evars realindvars scheme + induction_tac_felim with_evars realindvars scheme.nparams elim ] in - apply_induction_in_context isrec - None indsign (hyp0::indvars) names induct_tac gl + let elim = ElimUsing (({elimindex = Some scheme.index; elimbody = Option.get scheme.elimc}, scheme.elimt), indsign) in + apply_induction_in_context + None elim (hyp0::indvars) names induct_tac gl + +(* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the + hypothesis on which the induction is made *) +let induction_tac with_evars elim (varname,lbind) typ gl = + let ({elimindex=i;elimbody=(elimc,lbindelimc)},elimt) = elim in + let indclause = make_clenv_binding gl (mkVar varname,typ) lbind in + let i = match i with None -> index_of_ind_arg elimt | Some i -> i in + let elimclause = + make_clenv_binding gl + (mkCast (elimc,DEFAULTcast,elimt),elimt) lbindelimc in + elimination_clause_scheme with_evars true i elimclause indclause gl -let induction_from_context isrec with_evars elim_info (hyp0,lbind) names +let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) names inhyps gl = - let indsign,scheme = elim_info in - let indref = match scheme.indref with | None -> assert false | Some x -> x in let tmptyp0 = pf_get_hyp_typ gl hyp0 in let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in - let indvars = - find_atomic_param_of_ind scheme.nparams (snd (decompose_prod typ0)) in - let induct_tac = tclTHENLIST [ - induction_tac with_evars (hyp0,lbind) typ0 scheme; + let indvars = find_atomic_param_of_ind nparams ((strip_prod typ0)) in + let induct_tac elim = tclTHENLIST [ + induction_tac with_evars elim (hyp0,lbind) typ0; tclTRY (unfold_body hyp0); thin [hyp0] ] in - apply_induction_in_context isrec - (Some (hyp0,inhyps)) indsign indvars names induct_tac gl - -exception TryNewInduct of exn + apply_induction_in_context + (Some (hyp0,inhyps)) elim indvars names induct_tac gl let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps gl = - let (indsign,scheme as elim_info) = find_elim_signature isrec elim hyp0 gl in - if scheme.indarg = None then (* This is not a standard induction scheme (the - argument is probably a parameter) So try the - more general induction mechanism. *) - induction_from_context_l isrec with_evars elim_info [hyp0] names gl - else - let indref = match scheme.indref with | None -> assert false | Some x -> x in - tclTHEN - (atomize_param_of_ind (indref,scheme.nparams) hyp0) - (induction_from_context isrec with_evars elim_info - (hyp0,lbind) names inhyps) gl + let elim_info = find_induction_type isrec elim hyp0 gl in + tclTHEN + (atomize_param_of_ind elim_info hyp0) + (induction_from_context isrec with_evars elim_info + (hyp0,lbind) names inhyps) gl (* Induction on a list of induction arguments. Analyse the elim scheme (which is mandatory for multiple ind args), check that all @@ -2683,15 +3007,15 @@ let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbin let induction_without_atomization isrec with_evars elim names lid gl = let (indsign,scheme as elim_info) = find_elim_signature isrec elim (List.hd lid) gl in - let awaited_nargs = - scheme.nparams + scheme.nargs + let awaited_nargs = + scheme.nparams + scheme.nargs + (if scheme.farg_in_concl then 1 else 0) + (if scheme.indarg <> None then 1 else 0) in let nlid = List.length lid in if nlid <> awaited_nargs then error "Not the right number of induction arguments." - else induction_from_context_l isrec with_evars elim_info lid names gl + else induction_from_context_l with_evars elim_info lid names gl let enforce_eq_name id gl = function | (b,(loc,IntroAnonymous)) -> @@ -2714,7 +3038,7 @@ let clear_unselected_context id inhyps cls gl = | None -> tclIDTAC gl | Some cls -> if occur_var (pf_env gl) id (pf_concl gl) && - cls.concl_occs = no_occurrences_expr + cls.concl_occs = no_occurrences_expr then errorlabstrm "" (str "Conclusion must be mentioned: it depends on " ++ pr_id id ++ str "."); @@ -2736,21 +3060,21 @@ let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl = | _ -> [] in match kind_of_term c with | Var id when not (mem_named_context id (Global.named_context())) - & lbind = NoBindings & not with_evars & eqname = None + & lbind = NoBindings & not with_evars & eqname = None & not (has_selected_occurrences cls) -> tclTHEN (clear_unselected_context id inhyps cls) (induction_with_atomization_of_ind_arg isrec with_evars elim names (id,lbind) inhyps) gl | _ -> - let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) + let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in let id = fresh_id [] x gl in (* We need the equality name now *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) tclTHEN - (letin_tac_gen with_eq (Name id) c None (Option.default allClauses cls,false)) + (letin_tac_gen with_eq (Name id) c None (Option.default allHypsAndConcl cls,false)) (induction_with_atomization_of_ind_arg isrec with_evars elim names (id,lbind) inhyps) gl @@ -2771,22 +3095,22 @@ let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl = | c::l' -> match kind_of_term c with | Var id when not (mem_named_context id (Global.named_context())) - & not with_evars -> + & not with_evars -> let _ = newlc:= id::!newlc in atomize_list l' gl | _ -> - let x = + let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in - + let id = fresh_id [] x gl in let newl' = List.map (replace_term c (mkVar id)) l' in let _ = newlc:=id::!newlc in let _ = letids:=id::!letids in - tclTHEN - (letin_tac None (Name id) c None allClauses) + tclTHEN + (letin_tac None (Name id) c None allHypsAndConcl) (atomize_list newl') gl in - tclTHENLIST + tclTHENLIST [ (atomize_list lc); (fun gl' -> (* recompute each time to have the new value of newlc *) @@ -2798,64 +3122,65 @@ let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl = ] gl - -let induct_destruct_l isrec with_evars lc elim names cls = - (* Several induction hyps: induction scheme is mandatory *) - let _ = - if elim = None - then - errorlabstrm "" (strbrk "Induction scheme must be given when several induction hypothesis are given.\n" ++ - str "Example: induction x1 x2 x3 using my_scheme.") in - let newlc = - List.map - (fun x -> - match x with (* FIXME: should we deal with ElimOnIdent? *) - | ElimOnConstr (x,NoBindings) -> x - | _ -> error "Don't know where to find some argument.") - lc in - if cls <> None then - error - "'in' clause not supported when several induction hypothesis are given."; - new_induct_gen_l isrec with_evars elim names newlc - (* Induction either over a term, over a quantified premisse, or over several quantified premisses (like with functional induction - principles). + principles). TODO: really unify induction with one and induction with several args *) -let induct_destruct isrec with_evars (lc,elim,names,cls) = +let induct_destruct isrec with_evars (lc,elim,names,cls) gl = assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *) - if List.length lc = 1 then (* induction on one arg: use old mechanism *) - try + if List.length lc = 1 && not (is_functional_induction elim gl) then + (* standard induction *) + onInductionArg + (fun c -> new_induct_gen isrec with_evars elim names c cls) + (List.hd lc) gl + else begin + (* functional induction *) + (* Several induction hyps: induction scheme is mandatory *) + if elim = None + then + errorlabstrm "" (strbrk "Induction scheme must be given when several induction hypotheses are given.\n" ++ + str "Example: induction x1 x2 x3 using my_scheme."); + if cls <> None then + error "'in' clause not supported here."; + if List.length lc = 1 then + (* Hook to recover standard induction on non-standard induction schemes *) + (* will be removable when is_functional_induction will be more clever *) onInductionArg - (fun c -> new_induct_gen isrec with_evars elim names c cls) - (List.hd lc) - with (* If this fails, try with new mechanism but if it fails too, - then the exception is the first one. *) - | x -> - (try induct_destruct_l isrec with_evars lc elim names cls - with _ -> raise x) - else induct_destruct_l isrec with_evars lc elim names cls + (fun (c,lbind) -> + if lbind <> NoBindings then + error "'with' clause not supported here."; + new_induct_gen_l isrec with_evars elim names [c]) + (List.hd lc) gl + else + let newlc = + List.map (fun x -> + match x with (* FIXME: should we deal with ElimOnIdent? *) + | ElimOnConstr (x,NoBindings) -> x + | _ -> error "Don't know where to find some argument.") + lc in + new_induct_gen_l isrec with_evars elim names newlc gl + end let induction_destruct isrec with_evars = function - | [] -> tclIDTAC - | [a] -> induct_destruct isrec with_evars a - | a::l -> + | [],_ -> tclIDTAC + | [a,b,c],cl -> induct_destruct isrec with_evars (a,b,c,cl) + | (a,b,c)::l,cl -> tclTHEN - (induct_destruct isrec with_evars a) - (tclMAP (induct_destruct false with_evars) l) + (induct_destruct isrec with_evars (a,b,c,cl)) + (tclMAP (fun (a,b,c) -> induct_destruct false with_evars (a,b,c,cl)) l) let new_induct ev lc e idl cls = induct_destruct true ev (lc,e,idl,cls) let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls) (* The registered tactic, which calls the default elimination * if no elimination constant is provided. *) - + (* Induction tactics *) (* This was Induction before 6.3 (induction only in quantified premisses) *) -let raw_induct s = tclTHEN (intros_until_id s) (tclLAST_HYP simplest_elim) -let raw_induct_nodep n = tclTHEN (intros_until_n n) (tclLAST_HYP simplest_elim) +let raw_induct s = tclTHEN (intros_until_id s) (onLastHyp simplest_elim) +let raw_induct_nodep n = tclTHEN (intros_until_n n) (onLastHyp simplest_elim) let simple_induct_id hyp = raw_induct hyp let simple_induct_nodep = raw_induct_nodep @@ -2867,9 +3192,9 @@ let simple_induct = function (* Destruction tactics *) let simple_destruct_id s = - (tclTHEN (intros_until_id s) (tclLAST_HYP simplest_case)) + (tclTHEN (intros_until_id s) (onLastHyp simplest_case)) let simple_destruct_nodep n = - (tclTHEN (intros_until_n n) (tclLAST_HYP simplest_case)) + (tclTHEN (intros_until_n n) (onLastHyp simplest_case)) let simple_destruct = function | NamedHyp id -> simple_destruct_id id @@ -2878,7 +3203,7 @@ let simple_destruct = function (* * Eliminations giving the type instead of the proof. * These tactics use the default elimination constant and - * no substitutions at all. + * no substitutions at all. * May be they should be integrated into Elim ... *) @@ -2900,8 +3225,7 @@ let elim_type t gl = let case_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in - let env = pf_env gl in - let elimc = make_case_gen env (project gl) ind (elimination_sort_of_goal gl) in + let elimc = pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) in elim_scheme_type elimc t gl @@ -2910,10 +3234,10 @@ let case_type t gl = (* These elimination tactics are particularly adapted for sequent calculus. They take a clause as argument, and yield the elimination rule if the clause is of the form (Some id) and a - suitable introduction rule otherwise. They do not depend on - the name of the eliminated constant, so they can be also + suitable introduction rule otherwise. They do not depend on + the name of the eliminated constant, so they can be also used on ad-hoc disjunctions and conjunctions introduced by - the user. + the user. -- Eduardo Gimenez (11/8/97) HH (29/5/99) replaces failures by specific error messages @@ -2921,51 +3245,51 @@ let case_type t gl = let andE id gl = let t = pf_get_hyp_typ gl id in - if is_conjunction (pf_hnf_constr gl t) then + if is_conjunction (pf_hnf_constr gl t) then (tclTHEN (simplest_elim (mkVar id)) (tclDO 2 intro)) gl - else - errorlabstrm "andE" + else + errorlabstrm "andE" (str("Tactic andE expects "^(string_of_id id)^" is a conjunction.")) let dAnd cls = - onClauses + onClause (function | None -> simplest_split - | Some ((_,id),_) -> andE id) + | Some id -> andE id) cls let orE id gl = let t = pf_get_hyp_typ gl id in - if is_disjunction (pf_hnf_constr gl t) then + if is_disjunction (pf_hnf_constr gl t) then (tclTHEN (simplest_elim (mkVar id)) intro) gl - else - errorlabstrm "orE" + else + errorlabstrm "orE" (str("Tactic orE expects "^(string_of_id id)^" is a disjunction.")) let dorE b cls = - onClauses + onClause (function - | (Some ((_,id),_)) -> orE id - | None -> (if b then right else left) NoBindings) + | Some id -> orE id + | None -> (if b then right else left) NoBindings) cls let impE id gl = let t = pf_get_hyp_typ gl id in - if is_imp_term (pf_hnf_constr gl t) then - let (dom, _, rng) = destProd (pf_hnf_constr gl t) in + if is_imp_term (pf_hnf_constr gl t) then + let (dom, _, rng) = destProd (pf_hnf_constr gl t) in tclTHENLAST - (cut_intro rng) + (cut_intro rng) (apply_term (mkVar id) [mkMeta (new_meta())]) gl - else + else errorlabstrm "impE" (str("Tactic impE expects "^(string_of_id id)^ " is a an implication.")) - + let dImp cls = - onClauses + onClause (function | None -> intro - | Some ((_,id),_) -> impE id) + | Some id -> impE id) cls (************************************************) @@ -2978,21 +3302,19 @@ let setoid_reflexivity = ref (fun _ -> assert false) let register_setoid_reflexivity f = setoid_reflexivity := f let reflexivity_red allowred gl = - (* PL: usual reflexivity don't perform any reduction when searching - for an equality, but we may need to do some when called back from + (* PL: usual reflexivity don't perform any reduction when searching + for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = if not allowred then pf_concl gl - else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) - in + else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) + in match match_with_equality_type concl with - | None -> None - | Some _ -> Some (one_constructor 1 NoBindings) + | None -> raise NoEquationFound + | Some _ -> one_constructor 1 NoBindings gl + +let reflexivity gl = + try reflexivity_red false gl with NoEquationFound -> !setoid_reflexivity gl -let reflexivity gl = - match reflexivity_red false gl with - | None -> !setoid_reflexivity gl - | Some tac -> tac gl - let intros_reflexivity = (tclTHEN intros reflexivity) (* Symmetry tactics *) @@ -3005,74 +3327,67 @@ let intros_reflexivity = (tclTHEN intros reflexivity) let setoid_symmetry = ref (fun _ -> assert false) let register_setoid_symmetry f = setoid_symmetry := f +(* This is probably not very useful any longer *) +let prove_symmetry hdcncl eq_kind = + let symc = + match eq_kind with + | MonomorphicLeibnizEq (c1,c2) -> mkApp(hdcncl,[|c2;c1|]) + | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|]) + | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in + tclTHENFIRST (cut symc) + (tclTHENLIST + [ intro; + onLastHyp simplest_case; + one_constructor 1 NoBindings ]) + let symmetry_red allowred gl = - (* PL: usual symmetry don't perform any reduction when searching - for an equality, but we may need to do some when called back from + (* PL: usual symmetry don't perform any reduction when searching + for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) - let concl = if not allowred then pf_concl gl - else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) - in - match match_with_equation concl with - | None -> None - | Some (hdcncl,args) -> Some (fun gl -> - let hdcncls = string_of_inductive hdcncl in - begin - try - tclTHEN - (convert_concl_no_check concl DEFAULTcast) - (apply (pf_parse_const gl ("sym_"^hdcncls))) gl - with _ -> - let symc = match args with - | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) - | [typ;c1;c2] -> mkApp (hdcncl, [| typ; c2; c1 |]) - | [c1;c2] -> mkApp (hdcncl, [| c2; c1 |]) - | _ -> assert false - in - tclTHENFIRST (cut symc) - (tclTHENLIST - [ intro; - tclLAST_HYP simplest_case; - one_constructor 1 NoBindings ]) - gl - end) - -let symmetry gl = - match symmetry_red false gl with - | None -> !setoid_symmetry gl - | Some tac -> tac gl + let concl = + if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl) + in + match match_with_equation concl with + | Some eq_data,_,_ -> + tclTHEN + (convert_concl_no_check concl DEFAULTcast) + (apply eq_data.sym) gl + | None,eq,eq_kind -> prove_symmetry eq eq_kind gl + +let symmetry gl = + try symmetry_red false gl with NoEquationFound -> !setoid_symmetry gl let setoid_symmetry_in = ref (fun _ _ -> assert false) let register_setoid_symmetry_in f = setoid_symmetry_in := f -let symmetry_in id gl = - let ctype = pf_type_of gl (mkVar id) in +let symmetry_in id gl = + let ctype = pf_type_of gl (mkVar id) in let sign,t = decompose_prod_assum ctype in - match match_with_equation t with - | None -> !setoid_symmetry_in id gl - | Some (hdcncl,args) -> - let symccl = match args with - | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) - | [typ;c1;c2] -> mkApp (hdcncl, [| typ; c2; c1 |]) - | [c1;c2] -> mkApp (hdcncl, [| c2; c1 |]) - | _ -> assert false in - tclTHENS (cut (it_mkProd_or_LetIn symccl sign)) - [ intro_replacing id; - tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ] - gl + try + let _,hdcncl,eq = match_with_equation t in + let symccl = match eq with + | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |]) + | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |]) + | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in + tclTHENS (cut (it_mkProd_or_LetIn symccl sign)) + [ intro_replacing id; + tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ] + gl + with NoEquationFound -> !setoid_symmetry_in id gl let intros_symmetry = - onClauses + onClause (function | None -> tclTHEN intros symmetry - | Some ((_,id),_) -> symmetry_in id) + | Some id -> symmetry_in id) (* Transitivity tactics *) (* This tactic first tries to apply a constant named trans_eq, where eq is the name of the equality predicate. If this constant is not - defined and the conclusion is a=b, it solves the goal doing - Cut x1=x2; - [Cut x2=x3; [Intros e1 e2; Case e2;Assumption + defined and the conclusion is a=b, it solves the goal doing + Cut x1=x2; + [Cut x2=x3; [Intros e1 e2; Case e2;Assumption | Idtac] | Idtac] --Eduardo (19/8/97) @@ -3081,50 +3396,55 @@ let intros_symmetry = let setoid_transitivity = ref (fun _ _ -> assert false) let register_setoid_transitivity f = setoid_transitivity := f +(* This is probably not very useful any longer *) +let prove_transitivity hdcncl eq_kind t gl = + let eq1,eq2 = + match eq_kind with + | MonomorphicLeibnizEq (c1,c2) -> + (mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |])) + | PolymorphicLeibnizEq (typ,c1,c2) -> + (mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |])) + | HeterogenousEq (typ1,c1,typ2,c2) -> + let typt = pf_type_of gl t in + (mkApp(hdcncl, [| typ1; c1; typt ;t |]), + mkApp(hdcncl, [| typt; t; typ2; c2 |])) in + tclTHENFIRST (cut eq2) + (tclTHENFIRST (cut eq1) + (tclTHENLIST + [ tclDO 2 intro; + onLastHyp simplest_case; + assumption ])) gl + let transitivity_red allowred t gl = - (* PL: usual transitivity don't perform any reduction when searching - for an equality, but we may need to do some when called back from + (* PL: usual transitivity don't perform any reduction when searching + for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) - let concl = if not allowred then pf_concl gl - else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) - in + let concl = + if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl) + in match match_with_equation concl with - | None -> None - | Some (hdcncl,args) -> Some (fun gl -> - let hdcncls = string_of_inductive hdcncl in - begin - try - apply_list [(pf_parse_const gl ("trans_"^hdcncls));t] gl - with _ -> - let eq1, eq2 = match args with - | [typ1;c1;typ2;c2] -> let typt = pf_type_of gl t in - ( mkApp(hdcncl, [| typ1; c1; typt ;t |]), - mkApp(hdcncl, [| typt; t; typ2; c2 |]) ) - | [typ;c1;c2] -> - ( mkApp (hdcncl, [| typ; c1; t |]), - mkApp (hdcncl, [| typ; t; c2 |]) ) - | [c1;c2] -> - ( mkApp (hdcncl, [| c1; t|]), - mkApp (hdcncl, [| t; c2 |]) ) - | _ -> assert false - in - tclTHENFIRST (cut eq2) - (tclTHENFIRST (cut eq1) - (tclTHENLIST - [ tclDO 2 intro; - tclLAST_HYP simplest_case; - assumption ])) gl - end) - -let transitivity t gl = - match transitivity_red false t gl with - | None -> !setoid_transitivity t gl - | Some tac -> tac gl - -let intros_transitivity n = tclTHEN intros (transitivity n) - -(* tactical to save as name a subproof such that the generalisation of - the current goal, abstracted with respect to the local signature, + | Some eq_data,_,_ -> + tclTHEN + (convert_concl_no_check concl DEFAULTcast) + (match t with + | None -> eapply eq_data.trans + | Some t -> apply_list [eq_data.trans;t]) gl + | None,eq,eq_kind -> + match t with + | None -> error "etransitivity not supported for this relation." + | Some t -> prove_transitivity eq eq_kind t gl + +let transitivity_gen t gl = + try transitivity_red false t gl + with NoEquationFound -> !setoid_transitivity t gl + +let etransitivity = transitivity_gen None +let transitivity t = transitivity_gen (Some t) + +let intros_transitivity n = tclTHEN intros (transitivity_gen n) + +(* tactical to save as name a subproof such that the generalisation of + the current goal, abstracted with respect to the local signature, is solved by tac *) let interpretable_as_section_decl d1 d2 = match d1,d2 with @@ -3132,62 +3452,52 @@ let interpretable_as_section_decl d1 d2 = match d1,d2 with | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2 | (_,None,t1), (_,_,t2) -> eq_constr t1 t2 -let abstract_subproof name tac gl = +let abstract_subproof id tac gl = let current_sign = Global.named_context() and global_sign = pf_hyps gl in - let sign,secsign = + let sign,secsign = List.fold_right - (fun (id,_,_ as d) (s1,s2) -> + (fun (id,_,_ as d) (s1,s2) -> if mem_named_context id current_sign & interpretable_as_section_decl (Sign.lookup_named id current_sign) d then (s1,push_named_context_val d s2) - else (add_named_decl d s1,s2)) + else (add_named_decl d s1,s2)) global_sign (empty_named_context,empty_named_context_val) in - let na = next_global_ident_away false name (pf_ids_of_hyps gl) in + let id = next_global_ident_away id (pf_ids_of_hyps gl) in let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in - if occur_existential concl then - error "\"abstract\" cannot handle existentials."; - let lemme = - start_proof na (Global, Proof Lemma) secsign concl (fun _ _ -> ()); - let _,(const,_,kind,_) = - try - by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); - let r = cook_proof ignore in - delete_current_proof (); r - with - e -> - (delete_current_proof(); raise e) - in (* Faudrait un peu fonctionnaliser cela *) - let cd = Entries.DefinitionEntry const in - let con = Declare.declare_internal_constant na (cd,IsProof Lemma) in - constr_of_global (ConstRef con) - in - exact_no_check - (applist (lemme, - List.rev (Array.to_list (instance_from_named_context sign)))) - gl - -let tclABSTRACT name_op tac gl = - let s = match name_op with - | Some s -> s - | None -> add_suffix (get_current_proof_name ()) "_subproof" - in + let concl = + try flush_and_check_evars (project gl) concl + with Uninstantiated_evar _ -> + error "\"abstract\" cannot handle existentials." in + let const = Pfedit.build_constant_by_tactic secsign concl + (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)) in + let cd = Entries.DefinitionEntry const in + let lem = mkConst (Declare.declare_internal_constant id (cd,IsProof Lemma)) in + exact_no_check + (applist (lem,List.rev (Array.to_list (instance_from_named_context sign)))) + gl + +let tclABSTRACT name_op tac gl = + let s = match name_op with + | Some s -> s + | None -> add_suffix (get_current_proof_name ()) "_subproof" + in abstract_subproof s tac gl let admit_as_an_axiom gl = let current_sign = Global.named_context() and global_sign = pf_hyps gl in - let sign,secsign = + let sign,secsign = List.fold_right - (fun (id,_,_ as d) (s1,s2) -> + (fun (id,_,_ as d) (s1,s2) -> if mem_named_context id current_sign & interpretable_as_section_decl (Sign.lookup_named id current_sign) d then (s1,add_named_decl d s2) - else (add_named_decl d s1,s2)) + else (add_named_decl d s1,s2)) global_sign (empty_named_context,empty_named_context) in let name = add_suffix (get_current_proof_name ()) "_admitted" in - let na = next_global_ident_away false name (pf_ids_of_hyps gl) in + let na = next_global_ident_away name (pf_ids_of_hyps gl) in let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in if occur_existential concl then error"\"admit\" cannot handle existentials."; let axiom = @@ -3195,19 +3505,19 @@ let admit_as_an_axiom gl = let con = Declare.declare_internal_constant na (cd,IsAssumption Logical) in constr_of_global (ConstRef con) in - exact_no_check - (applist (axiom, + exact_no_check + (applist (axiom, List.rev (Array.to_list (instance_from_named_context sign)))) gl let unify ?(state=full_transparent_state) x y gl = - try - let flags = - {default_unify_flags with + try + let flags = + {default_unify_flags with modulo_delta = state; modulo_conv_on_closed_terms = Some state} in - let evd = w_unify false (pf_env gl) Reduction.CONV + let evd = w_unify false (pf_env gl) Reduction.CONV ~flags x y (Evd.create_evar_defs (project gl)) - in tclEVARS (Evd.evars_of evd) gl + in tclEVARS evd gl with _ -> tclFAIL 0 (str"Not unifiable") gl diff --git a/tactics/tactics.mli b/tactics/tactics.mli index fb5c0efd..0e552bd4 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tactics.mli 11735 2009-01-02 17:22:31Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Util @@ -27,20 +27,14 @@ open Genarg open Tacexpr open Nametab open Rawterm +open Pattern open Termops (*i*) -val inj_open : constr -> open_constr -val inj_red_expr : red_expr -> (open_constr, evaluable_global_reference) red_expr_gen -val inj_ebindings : constr bindings -> open_constr bindings - (* Main tactics. *) (*s General functions. *) -val type_clenv_binding : goal sigma -> - constr * constr -> open_constr bindings -> constr - val string_of_inductive : constr -> string val head_constr : constr -> constr * constr list val head_constr_bound : constr -> constr * constr list @@ -56,19 +50,19 @@ val convert_concl : constr -> cast_kind -> tactic val convert_hyp : named_declaration -> tactic val thin : identifier list -> tactic val mutual_fix : - identifier -> int -> (identifier * int * constr) list -> tactic + identifier -> int -> (identifier * int * constr) list -> int -> tactic val fix : identifier option -> int -> tactic -val mutual_cofix : identifier -> (identifier * constr) list -> tactic +val mutual_cofix : identifier -> (identifier * constr) list -> int -> tactic val cofix : identifier option -> tactic (*s Introduction tactics. *) +val fresh_id_in_env : identifier list -> identifier -> env -> identifier val fresh_id : identifier list -> identifier -> goal sigma -> identifier val find_intro_names : rel_context -> goal sigma -> identifier list val intro : tactic val introf : tactic -val intro_force : bool -> tactic val intro_move : identifier option -> identifier move_location -> tactic (* [intro_avoiding idl] acts as intro but prevents the new identifier @@ -106,9 +100,9 @@ val try_intros_until : (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) -val onInductionArg : - (constr with_ebindings -> tactic) -> - constr with_ebindings induction_arg -> tactic +val onInductionArg : + (constr with_bindings -> tactic) -> + constr with_bindings induction_arg -> tactic (*s Introduction tactics with eliminations. *) @@ -130,35 +124,35 @@ val exact_proof : Topconstr.constr_expr -> tactic type tactic_reduction = env -> evar_map -> constr -> constr val reduct_in_hyp : tactic_reduction -> hyp_location -> tactic -val reduct_option : tactic_reduction * cast_kind -> simple_clause -> tactic +val reduct_option : tactic_reduction * cast_kind -> goal_location -> tactic val reduct_in_concl : tactic_reduction * cast_kind -> tactic -val change_in_concl : (occurrences * constr) option -> constr -> tactic -val change_in_hyp : (occurrences * constr) option -> constr -> +val change_in_concl : (occurrences * constr_pattern) option -> constr -> + tactic +val change_in_hyp : (occurrences * constr_pattern) option -> constr -> hyp_location -> tactic val red_in_concl : tactic -val red_in_hyp : hyp_location -> tactic -val red_option : simple_clause -> tactic +val red_in_hyp : hyp_location -> tactic +val red_option : goal_location -> tactic val hnf_in_concl : tactic -val hnf_in_hyp : hyp_location -> tactic -val hnf_option : simple_clause -> tactic +val hnf_in_hyp : hyp_location -> tactic +val hnf_option : goal_location -> tactic val simpl_in_concl : tactic -val simpl_in_hyp : hyp_location -> tactic -val simpl_option : simple_clause -> tactic +val simpl_in_hyp : hyp_location -> tactic +val simpl_option : goal_location -> tactic val normalise_in_concl : tactic -val normalise_in_hyp : hyp_location -> tactic -val normalise_option : simple_clause -> tactic +val normalise_in_hyp : hyp_location -> tactic +val normalise_option : goal_location -> tactic val normalise_vm_in_concl : tactic val unfold_in_concl : (occurrences * evaluable_global_reference) list -> tactic -val unfold_in_hyp : +val unfold_in_hyp : (occurrences * evaluable_global_reference) list -> hyp_location -> tactic -val unfold_option : - (occurrences * evaluable_global_reference) list -> simple_clause - -> tactic +val unfold_option : + (occurrences * evaluable_global_reference) list -> goal_location -> tactic val change : - (occurrences * constr) option -> constr -> clause -> tactic -val pattern_option : - (occurrences * constr) list -> simple_clause -> tactic + constr_pattern option -> constr -> clause -> tactic +val pattern_option : + (occurrences * constr) list -> goal_location -> tactic val reduce : red_expr -> clause -> tactic val unfold_constr : global_reference -> tactic @@ -168,7 +162,7 @@ val clear : identifier list -> tactic val clear_body : identifier list -> tactic val keep : identifier list -> tactic -val specialize : int option -> constr with_ebindings -> tactic +val specialize : int option -> constr with_bindings -> tactic val move_hyp : bool -> identifier -> identifier move_location -> tactic val rename_hyp : (identifier * identifier) list -> tactic @@ -181,32 +175,30 @@ val apply_type : constr -> constr list -> tactic val apply_term : constr -> constr list -> tactic val bring_hyps : named_context -> tactic -val apply : constr -> tactic -val apply_without_reduce : constr -> tactic -val apply_list : constr list -> tactic - -val apply_with_ebindings_gen : - advanced_flag -> evars_flag -> open_constr with_ebindings list -> tactic +val apply : constr -> tactic +val eapply : constr -> tactic + +val apply_with_bindings_gen : + advanced_flag -> evars_flag -> constr with_bindings located list -> tactic val apply_with_bindings : constr with_bindings -> tactic val eapply_with_bindings : constr with_bindings -> tactic -val apply_with_ebindings : open_constr with_ebindings -> tactic -val eapply_with_ebindings : open_constr with_ebindings -> tactic - val cut_and_apply : constr -> tactic -val apply_in : +val apply_in : advanced_flag -> evars_flag -> identifier -> - open_constr with_ebindings list -> - intro_pattern_expr located option -> tactic + constr with_bindings located list -> + intro_pattern_expr located option -> tactic + +val simple_apply_in : identifier -> constr -> tactic (*s Elimination tactics. *) (* The general form of an induction principle is the following: - + forall prm1 prm2 ... prmp, (induction parameters) forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates) branch1, branch2, ... , branchr, (branches of the principle) @@ -229,66 +221,82 @@ val apply_in : (* [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) -type elim_scheme = { - elimc: constr with_ebindings option; +type elim_scheme = { + elimc: constr with_bindings option; elimt: types; indref: global_reference option; + index: int; (* index of the elimination type in the scheme *) params: rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (* number of parameters *) predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) npredicates: int; (* Number of predicates *) branches: rel_context; (* branchr,...,branch1 *) - nbranches: int; (* Number of branches *) + nbranches: int; (* Number of branches *) args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (* number of arguments *) - indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) + indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) - concl: types; (* Qi x1...xni HI (f...), HI and (f...) + concl: types; (* Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) } -val compute_elim_sig : ?elimc: constr with_ebindings -> types -> elim_scheme +val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme val rebuild_elimtype_from_scheme: elim_scheme -> types +(* elim principle with the index of its inductive arg *) +type eliminator = { + elimindex : int option; (* None = find it automatically *) + elimbody : constr with_bindings +} + +val elimination_clause_scheme : evars_flag -> + bool -> int -> clausenv -> clausenv -> tactic + +val elimination_in_clause_scheme : evars_flag -> identifier -> int -> + clausenv -> clausenv -> tactic + +val general_elim_clause_gen : (int -> Clenv.clausenv -> 'a -> tactic) -> + 'a -> eliminator -> tactic + val general_elim : evars_flag -> - constr with_ebindings -> constr with_ebindings -> ?allow_K:bool -> tactic -val general_elim_in : evars_flag -> - identifier -> constr with_ebindings -> constr with_ebindings -> tactic + constr with_bindings -> eliminator -> ?allow_K:bool -> tactic +val general_elim_in : evars_flag -> + identifier -> constr with_bindings -> eliminator -> tactic -val default_elim : evars_flag -> constr with_ebindings -> tactic +val default_elim : evars_flag -> constr with_bindings -> tactic val simplest_elim : constr -> tactic -val elim : - evars_flag -> constr with_ebindings -> constr with_ebindings option -> tactic +val elim : + evars_flag -> constr with_bindings -> constr with_bindings option -> tactic val simple_induct : quantified_hypothesis -> tactic -val new_induct : evars_flag -> constr with_ebindings induction_arg list -> - constr with_ebindings option -> - intro_pattern_expr located option * intro_pattern_expr located option -> - clause option -> tactic +val new_induct : evars_flag -> constr with_bindings induction_arg list -> + constr with_bindings option -> + intro_pattern_expr located option * intro_pattern_expr located option -> + clause option -> tactic (*s Case analysis tactics. *) -val general_case_analysis : evars_flag -> constr with_ebindings -> tactic +val general_case_analysis : evars_flag -> constr with_bindings -> tactic val simplest_case : constr -> tactic val simple_destruct : quantified_hypothesis -> tactic -val new_destruct : evars_flag -> constr with_ebindings induction_arg list -> - constr with_ebindings option -> - intro_pattern_expr located option * intro_pattern_expr located option -> - clause option -> tactic +val new_destruct : evars_flag -> constr with_bindings induction_arg list -> + constr with_bindings option -> + intro_pattern_expr located option * intro_pattern_expr located option -> + clause option -> tactic (*s Generic case analysis / induction tactics. *) -val induction_destruct : evars_flag -> rec_flag -> - (constr with_ebindings induction_arg list * - constr with_ebindings option * - (intro_pattern_expr located option * intro_pattern_expr located option) * - clause option) list -> - tactic +val induction_destruct : rec_flag -> evars_flag -> + (constr with_bindings induction_arg list * + constr with_bindings option * + (intro_pattern_expr located option * intro_pattern_expr located option)) + list * + clause option -> tactic (*s Eliminations giving the type instead of the proof. *) @@ -307,18 +315,18 @@ val dorE : bool -> clause ->tactic (*s Introduction tactics. *) -val constructor_tac : evars_flag -> int option -> int -> - open_constr bindings -> tactic +val constructor_tac : evars_flag -> int option -> int -> + constr bindings -> tactic val any_constructor : evars_flag -> tactic option -> tactic -val one_constructor : int -> open_constr bindings -> tactic +val one_constructor : int -> constr bindings -> tactic val left : constr bindings -> tactic val right : constr bindings -> tactic val split : constr bindings -> tactic -val left_with_ebindings : evars_flag -> open_constr bindings -> tactic -val right_with_ebindings : evars_flag -> open_constr bindings -> tactic -val split_with_ebindings : evars_flag -> open_constr bindings -> tactic +val left_with_bindings : evars_flag -> constr bindings -> tactic +val right_with_bindings : evars_flag -> constr bindings -> tactic +val split_with_bindings : evars_flag -> constr bindings list -> tactic val simplest_left : tactic val simplest_right : tactic @@ -327,31 +335,32 @@ val simplest_split : tactic (*s Logical connective tactics. *) val register_setoid_reflexivity : tactic -> unit -val reflexivity_red : bool -> goal sigma -> tactic option +val reflexivity_red : bool -> tactic val reflexivity : tactic val intros_reflexivity : tactic val register_setoid_symmetry : tactic -> unit -val symmetry_red : bool -> goal sigma -> tactic option +val symmetry_red : bool -> tactic val symmetry : tactic val register_setoid_symmetry_in : (identifier -> tactic) -> unit val symmetry_in : identifier -> tactic val intros_symmetry : clause -> tactic -val register_setoid_transitivity : (constr -> tactic) -> unit -val transitivity_red : bool -> constr -> goal sigma -> tactic option +val register_setoid_transitivity : (constr option -> tactic) -> unit +val transitivity_red : bool -> constr option -> tactic val transitivity : constr -> tactic -val intros_transitivity : constr -> tactic +val etransitivity : tactic +val intros_transitivity : constr option -> tactic val cut : constr -> tactic val cut_intro : constr -> tactic -val cut_replacing : - identifier -> constr -> (tactic -> tactic) -> tactic +val assert_replacing : identifier -> types -> tactic -> tactic +val cut_replacing : identifier -> types -> tactic -> tactic val cut_in_parallel : constr list -> tactic val assert_as : bool -> intro_pattern_expr located option -> constr -> tactic val forward : tactic option -> intro_pattern_expr located option -> constr -> tactic -val letin_tac : (bool * intro_pattern_expr located) option -> name -> +val letin_tac : (bool * intro_pattern_expr located) option -> name -> constr -> types option -> clause -> tactic val assert_tac : name -> types -> tactic val assert_by : name -> types -> tactic -> tactic @@ -359,7 +368,7 @@ val pose_proof : name -> constr -> tactic val generalize : constr list -> tactic val generalize_gen : ((occurrences * constr) * name) list -> tactic -val generalize_dep : constr -> tactic +val generalize_dep : ?with_let:bool (* Don't lose let bindings *) -> constr -> tactic val unify : ?state:Names.transparent_state -> constr -> constr -> tactic val resolve_classes : tactic @@ -368,9 +377,8 @@ val tclABSTRACT : identifier option -> tactic -> tactic val admit_as_an_axiom : tactic -val abstract_generalize : identifier -> ?generalize_vars:bool -> tactic - -val dependent_pattern : constr -> tactic +val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> identifier -> tactic +val specialize_eqs : identifier -> tactic -val register_general_multi_rewrite : - (bool -> evars_flag -> open_constr with_bindings -> clause -> tactic) -> unit +val register_general_multi_rewrite : + (bool -> evars_flag -> constr with_bindings -> clause -> tactic) -> unit diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib new file mode 100644 index 00000000..0a634138 --- /dev/null +++ b/tactics/tactics.mllib @@ -0,0 +1,23 @@ +Dn +Termdn +Btermdn +Nbtermdn +Tacticals +Hipattern +Ind_tables +Eqschemes +Elimschemes +Tactics +Hiddentac +Elim +Dhyp +Auto +Equality +Contradiction +Inv +Leminv +Tacinterp +Evar_tactics +Autorewrite +Decl_interp +Decl_proof_instr diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index d3e7da6a..3e7266d7 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: tauto.ml4 12955 2010-04-20 08:10:14Z herbelin $ i*) +(*i $Id$ i*) open Term open Hipattern @@ -24,7 +24,7 @@ open Genarg let assoc_var s ist = match List.assoc (Names.id_of_string s) ist.lfun with - | VConstr c -> c + | VConstr ([],c) -> c | _ -> failwith "tauto: anomaly" (** Parametrization of tauto *) @@ -46,6 +46,19 @@ let strict_in_hyp_and_ccl = false (* Whether unit type includes equality types *) let strict_unit = false +(* Whether inner iff are unfolded *) +let iff_unfolding = ref false + +let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 + +open Goptions +let _ = + declare_bool_option + { optsync = true; + optname = "unfolding of iff and not in intuition"; + optkey = ["Intuition";"Iff";"Unfolding"]; + optread = (fun () -> !iff_unfolding); + optwrite = (:=) iff_unfolding } (** Test *) @@ -67,7 +80,7 @@ let is_unit_or_eq ist = let is_record t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in mib.Declarations.mind_record | _ -> false @@ -76,13 +89,13 @@ let is_binary t = isApp t && let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in mib.Declarations.mind_nparams = 2 | _ -> false let iter_tac tacl = - List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl + List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl (** Dealing with conjunction *) @@ -102,17 +115,17 @@ let flatten_contravariant_conj ist = match match_with_conjunction ~strict:strict_in_contravariant_hyp typ with | Some (_,args) -> let i = List.length args in - if not binary_mode || i = 2 then - let newtyp = valueIn (VConstr (List.fold_right mkArrow args c)) in - let hyp = valueIn (VConstr hyp) in + if not binary_mode || i = 2 then + let newtyp = valueIn (VConstr ([],List.fold_right mkArrow args c)) in + let hyp = valueIn (VConstr ([],hyp)) in let intros = - iter_tac (List.map (fun _ -> <:tactic< intro >>) args) + iter_tac (List.map (fun _ -> <:tactic< intro >>) args) <:tactic< idtac >> in <:tactic< let newtyp := $newtyp in let hyp := $hyp in - assert newtyp by ($intros; apply hyp; split; assumption); - clear hyp + assert newtyp by ($intros; apply hyp; split; assumption); + clear hyp >> else <:tactic<fail>> @@ -137,15 +150,15 @@ let flatten_contravariant_disj ist = match match_with_disjunction ~strict:strict_in_contravariant_hyp typ with | Some (_,args) -> let i = List.length args in - if not binary_mode || i = 2 then - let hyp = valueIn (VConstr hyp) in + if not binary_mode || i = 2 then + let hyp = valueIn (VConstr ([],hyp)) in iter_tac (list_map_i (fun i arg -> - let typ = valueIn (VConstr (mkArrow arg c)) in - <:tactic< + let typ = valueIn (VConstr ([],mkArrow arg c)) in + <:tactic< let typ := $typ in let hyp := $hyp in - assert typ by (intro; apply hyp; constructor $i; assumption) - >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >> + assert typ by (intro; apply hyp; constructor $i; assumption) + >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >> else <:tactic<fail>> | _ -> @@ -162,7 +175,7 @@ let not_dep_intros ist = | H:(Coq.Init.Logic.not _)|-_ => unfold Coq.Init.Logic.not at 1 in H | H:(Coq.Init.Logic.not _)->_|-_ => unfold Coq.Init.Logic.not at 1 in H end >> - + let axioms ist = let t_is_unit_or_eq = tacticIn is_unit_or_eq and t_is_empty = tacticIn is_empty in @@ -187,8 +200,9 @@ let simplif ist = (match reverse goal with | id: ?X1 |- _ => $t_is_conj; elim id; do 2 intro; clear id | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id + | id: (Coq.Init.Logic.not _) |- _ => red in id | id: ?X1 |- _ => $t_is_disj; elim id; intro; clear id - | id0: ?X1-> ?X2, id1: ?X1|- _ => + | id0: ?X1 -> ?X2, id1: ?X1|- _ => (* generalize (id0 id1); intro; clear id0 does not work (see Marco Maggiesi's bug PR#301) so we instead use Assert and exact. *) @@ -208,9 +222,10 @@ let simplif ist = clear id | id: ?X1 -> ?X2|- _ => $t_flatten_contravariant_disj - (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2|-" and "?B->?X2|-" *) + (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2,?B->?X2|-" *) | |- ?X1 => $t_is_conj; split | |- (Coq.Init.Logic.iff _ _) => split + | |- (Coq.Init.Logic.not _) => red end; $t_not_dep_intros) >> @@ -223,9 +238,9 @@ let rec tauto_intuit t_reduce solver ist = <:tactic< ($t_simplif;$t_axioms || match reverse goal with - | id:(?X1-> ?X2)-> ?X3|- _ => + | id:(?X1 -> ?X2)-> ?X3|- _ => cut X3; - [ intro; clear id; $t_tauto_intuit + [ intro; clear id; $t_tauto_intuit | cut (X1 -> X2); [ exact id | generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id; @@ -242,22 +257,42 @@ let rec tauto_intuit t_reduce solver ist = $t_solver ) >> -let reduction_not_iff _ist = - <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >> +let reduction_not _ist = + if unfold_iff () then + <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >> + else + <:tactic< unfold Coq.Init.Logic.not in * >> -let t_reduction_not_iff = tacticIn reduction_not_iff +let t_reduction_not = tacticIn reduction_not let intuition_gen tac = - interp (tacticIn (tauto_intuit t_reduction_not_iff tac)) + interp (tacticIn (tauto_intuit t_reduction_not tac)) let simplif_gen = interp (tacticIn simplif) -let tauto g = +let tauto_intuitionistic g = try intuition_gen <:tactic<fail>> g with Refiner.FailError _ | UserError _ -> errorlabstrm "tauto" (str "tauto failed.") +let coq_nnpp_path = + let dir = List.map id_of_string ["Classical_Prop";"Logic";"Coq"] in + Libnames.make_path (make_dirpath dir) (id_of_string "NNPP") + +let tauto_classical nnpp g = + try tclTHEN (apply nnpp) tauto_intuitionistic g + with UserError _ -> errorlabstrm "tauto" (str "Classical tauto failed.") + +let tauto g = + try + let nnpp = constr_of_global (Nametab.global_of_path coq_nnpp_path) in + (* try intuitionistic version first to avoid an axiom if possible *) + tclORELSE tauto_intuitionistic (tauto_classical nnpp) g + with Not_found -> + tauto_intuitionistic g + + let default_intuition_tac = <:tactic< auto with * >> TACTIC EXTEND tauto diff --git a/tactics/termdn.ml b/tactics/termdn.ml index bd439fb4..7b6d3ea7 100644 --- a/tactics/termdn.ml +++ b/tactics/termdn.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: termdn.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id$ *) open Util open Names @@ -20,25 +20,60 @@ open Nametab (* Discrimination nets of terms. See the module dn.ml for further explanations. Eduardo (5/8/97) *) +module Make = + functor (Z : Map.OrderedType) -> +struct -type 'a t = (global_reference,constr_pattern,'a) Dn.t + module X = struct + type t = constr_pattern + let compare = Pervasives.compare + end + + type term_label = + | GRLabel of global_reference + | ProdLabel + | LambdaLabel + | SortLabel of sorts option + + module Y = struct + type t = term_label + let compare x y = + let make_name n = + match n with + | GRLabel(ConstRef con) -> + GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | GRLabel(IndRef (kn,i)) -> + GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | GRLabel(ConstructRef ((kn,i),j ))-> + GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + + module Dn = Dn.Make(X)(Y)(Z) + + type t = Dn.t + + type 'a lookup_res = 'a Dn.lookup_res (*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*) -let decomp = +let 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 + in decrec [] -let decomp_pat = +let decomp_pat = let rec decrec acc = function | PApp (f,args) -> decrec (Array.to_list args @ acc) f | c -> (c,acc) - in - decrec [] + in + decrec [] let constr_pat_discr t = if not (occur_meta_pattern t) then @@ -46,49 +81,63 @@ let constr_pat_discr t = else match decomp_pat t with | PRef ((IndRef _) as ref), args - | PRef ((ConstructRef _ ) as ref), args -> Some (ref,args) - | PRef ((VarRef v) as ref), args -> Some(ref,args) + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) | _ -> None let constr_pat_discr_st (idpred,cpred) t = match decomp_pat t with | PRef ((IndRef _) as ref), args - | PRef ((ConstructRef _ ) as ref), args -> Some (ref,args) - | PRef ((VarRef v) as ref), args when not (Idpred.mem v idpred) -> - Some(ref,args) + | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) + | PRef ((VarRef v) as ref), args when not (Idpred.mem v idpred) -> + Some(GRLabel ref,args) | PVar v, args when not (Idpred.mem v idpred) -> - Some(VarRef v,args) + Some(GRLabel (VarRef v),args) | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) -> - Some (ref, args) + Some (GRLabel ref, args) + | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) + | PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l) + | PSort s, [] -> + let s' = match s with + | RProp c -> Some (Prop c) + | RType _ -> None + (* Don't try to be clever about type levels here *) + in Some (SortLabel s', []) | _ -> None open Dn -let constr_val_discr t = +let constr_val_discr t = let c, l = decomp t in match kind_of_term c with - | Ind ind_sp -> Label(IndRef ind_sp,l) - | Construct cstr_sp -> Label((ConstructRef cstr_sp),l) - | Var id -> Label(VarRef id,l) + | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l) + | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l) + | Var id -> Label(GRLabel (VarRef id),l) | Const _ -> Everything | _ -> Nothing - -let constr_val_discr_st (idpred,cpred) t = + +let constr_val_discr_st (idpred,cpred) t = let c, l = decomp t in match kind_of_term c with - | Const c -> if Cpred.mem c cpred then Everything else Label(ConstRef c,l) - | Ind ind_sp -> Label(IndRef ind_sp,l) - | Construct cstr_sp -> Label((ConstructRef cstr_sp),l) - | Var id when not (Idpred.mem id idpred) -> Label(VarRef id,l) + | Const c -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) + | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l) + | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l) + | Var id when not (Idpred.mem id idpred) -> Label(GRLabel (VarRef id),l) + | Prod (n, d, c) -> Label(ProdLabel, [d; c]) + | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l) + | Sort s when is_small s -> Label(SortLabel (Some s), []) + | Sort _ -> Label (SortLabel None, []) | Evar _ -> Everything | _ -> Nothing -let create = Dn.create +let create = Dn.create let add dn st = Dn.add dn (constr_pat_discr_st st) let rmv dn st = Dn.rmv dn (constr_pat_discr_st st) let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t - + let app f dn = Dn.app f dn + +end diff --git a/tactics/termdn.mli b/tactics/termdn.mli index 79efd8eb..aea49b07 100644 --- a/tactics/termdn.mli +++ b/tactics/termdn.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: termdn.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id$ i*) (*i*) open Term @@ -14,7 +14,7 @@ open Pattern open Libnames open Names (*i*) - + (* Discrimination nets of terms. *) (* This module registers actions (typically tactics) mapped to patterns *) @@ -23,37 +23,50 @@ open Names order in such a way patterns having the same prefix have this common prefix shared and the seek for the action associated to the patterns that a term matches are found in time proportional to the maximal -number of nodes of the patterns matching the term. The [transparent_state] +number of nodes of the patterns matching the term. The [transparent_state] indicates which constants and variables can be considered as rigid. These dnets are able to cope with existential variables as well, which match [Everything]. *) -type 'a t - -val create : unit -> 'a t - -(* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *) - -val add : 'a t -> transparent_state -> (constr_pattern * 'a) -> 'a t - -val rmv : 'a t -> transparent_state -> (constr_pattern * 'a) -> 'a t - -(* [lookup t c] looks for patterns (with their action) matching term [c] *) - -val lookup : 'a t -> transparent_state -> constr -> (constr_pattern * 'a) list - -val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit - - -(*i*) -(* These are for Nbtermdn *) - -val constr_pat_discr_st : transparent_state -> - constr_pattern -> (global_reference * constr_pattern list) option -val constr_val_discr_st : transparent_state -> - constr -> (global_reference * constr list) Dn.lookup_res - -val constr_pat_discr : constr_pattern -> (global_reference * constr_pattern list) option -val constr_val_discr : constr -> (global_reference * constr list) Dn.lookup_res - +module Make : + functor (Z : Map.OrderedType) -> +sig + + type t + + type 'a lookup_res + + val create : unit -> t + + (* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *) + + val add : t -> transparent_state -> (constr_pattern * Z.t) -> t + + val rmv : t -> transparent_state -> (constr_pattern * Z.t) -> t + + (* [lookup t c] looks for patterns (with their action) matching term [c] *) + + val lookup : t -> transparent_state -> constr -> (constr_pattern * Z.t) list + + val app : ((constr_pattern * Z.t) -> unit) -> t -> unit + + + (*i*) + (* These are for Nbtermdn *) + + type term_label = + | GRLabel of global_reference + | ProdLabel + | LambdaLabel + | SortLabel of sorts option + + val constr_pat_discr_st : transparent_state -> + constr_pattern -> (term_label * constr_pattern list) option + val constr_val_discr_st : transparent_state -> + constr -> (term_label * constr list) lookup_res + + val constr_pat_discr : constr_pattern -> (term_label * constr_pattern list) option + val constr_val_discr : constr -> (term_label * constr list) lookup_res + (*i*) +end |