summaryrefslogtreecommitdiff
path: root/tactics
diff options
context:
space:
mode:
authorGravatar Stephane Glondu <steph@glondu.net>2009-02-01 00:54:40 +0100
committerGravatar Stephane Glondu <steph@glondu.net>2009-02-01 00:54:40 +0100
commitcfbfe13f5b515ae2e3c6cdd97e2ccee03bc26e56 (patch)
treeb7832bd5d412a5a5d69cb36ae2ded62c71124c22 /tactics
parent113b703a695acbe31ac6dd6a8c4aa94f6fda7545 (diff)
Imported Upstream version 8.2~rc2+dfsgupstream/8.2.rc2+dfsg
Diffstat (limited to 'tactics')
-rw-r--r--tactics/auto.ml574
-rw-r--r--tactics/auto.mli52
-rw-r--r--tactics/class_tactics.ml4872
-rw-r--r--tactics/decl_interp.ml8
-rw-r--r--tactics/decl_proof_instr.ml10
-rw-r--r--tactics/decl_proof_instr.mli2
-rw-r--r--tactics/dhyp.ml5
-rw-r--r--tactics/eauto.ml436
-rw-r--r--tactics/elim.ml4
-rw-r--r--tactics/equality.ml169
-rw-r--r--tactics/equality.mli12
-rw-r--r--tactics/evar_tactics.ml4
-rw-r--r--tactics/evar_tactics.mli3
-rw-r--r--tactics/extraargs.ml421
-rw-r--r--tactics/extraargs.mli10
-rw-r--r--tactics/extratactics.ml4103
-rw-r--r--tactics/hiddentac.ml15
-rw-r--r--tactics/hiddentac.mli9
-rw-r--r--tactics/hipattern.ml4173
-rw-r--r--tactics/hipattern.mli22
-rw-r--r--tactics/inv.ml40
-rw-r--r--tactics/refine.ml6
-rw-r--r--tactics/setoid_replace.ml2023
-rw-r--r--tactics/setoid_replace.mli85
-rw-r--r--tactics/tacinterp.ml329
-rw-r--r--tactics/tacinterp.mli12
-rw-r--r--tactics/tacticals.ml44
-rw-r--r--tactics/tacticals.mli10
-rw-r--r--tactics/tactics.ml710
-rw-r--r--tactics/tactics.mli43
-rw-r--r--tactics/tauto.ml4166
31 files changed, 2038 insertions, 3534 deletions
diff --git a/tactics/auto.ml b/tactics/auto.ml
index 066ed786..1212656b 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: auto.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: auto.ml 11739 2009-01-02 19:33:19Z herbelin $ *)
open Pp
open Util
@@ -59,6 +59,8 @@ type pri_auto_tactic = {
code : auto_tactic (* the tactic to apply when the concl matches pat *)
}
+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
@@ -110,34 +112,60 @@ module Constr_map = Map.Make(struct
let compare = Pervasives.compare
end)
+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 = {
hintdb_state : Names.transparent_state;
use_dn : bool;
- hintdb_map : search_entry Constr_map.t
+ 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
}
- let empty use_dn = { hintdb_state = empty_transparent_state;
- use_dn = use_dn;
- hintdb_map = Constr_map.empty }
+ let empty st use_dn = { hintdb_state = st;
+ 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_all k db =
let (l,l',_) = find k db in
- Sort.merge pri_order l l'
+ Sort.merge pri_order (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
- lookup_tacs (k,c) st (find k db)
-
+ let l' = lookup_tacs (k,c) st (find k db) in
+ Sort.merge pri_order 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
@@ -148,27 +176,43 @@ module Hint_db = struct
| EvalConstRef cst -> (ids, Cpred.add cst csts)), true
| _ -> db.hintdb_state, false
in
- let dnst, db =
- if db.use_dn then
- Some st', { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map }
- else None, db
+ 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
in
- let oval = find k db in
let pat = if not db.use_dn && is_exact v.code then None else v.pat in
- { db with hintdb_map = Constr_map.add k (add_tac pat v dnst oval) db.hintdb_map;
- hintdb_state = st' }
+ match k with
+ | None ->
+ if not (List.mem v db.hintdb_nopat) then
+ { db with hintdb_nopat = 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' }
let add_list l db = List.fold_right add_one l db
- let iter f db = Constr_map.iter (fun k (l,l',_) -> f k (l@l')) db.hintdb_map
+ let iter f db =
+ f None 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 = { db with hintdb_state = st }
+ 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 }
- let set_rigid db cst =
- let (ids,csts) = db.hintdb_state in
- { db with hintdb_state = (ids, Cpred.remove cst csts) }
+ let use_dn db = db.use_dn
+
end
module Hintdbmap = Gmap
@@ -235,21 +279,21 @@ let make_exact_entry pri (c,cty) =
let ce = mk_clenv_from dummy_goal (c,cty) in
let c' = clenv_type ce in
let pat = Pattern.pattern_of_constr c' in
- (head_of_constr_reference (List.hd (head_constr cty)),
+ (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 make_apply_entry env sigma (eapply,verbose) pri (c,cty) =
- let cty = hnf_constr env sigma cty in
- match kind_of_term cty with
+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 hd = (try head_pattern_bound pat
- with BoundPattern -> failwith "make_apply_entry") in
+ with BoundPattern -> failwith "make_apply_entry") in
let nmiss = List.length (clenv_missing ce) in
if nmiss = 0 then
- (hd,
+ (Some hd,
{ pri = (match pri with None -> nb_hyp cty | Some p -> p);
pat = Some pat;
code = Res_pf(c,{ce with env=empty_env}) })
@@ -258,14 +302,14 @@ let make_apply_entry env sigma (eapply,verbose) pri (c,cty) =
if verbose then
warn (str "the hint: eapply " ++ pr_lconstr c ++
str " will only be used by eauto");
- (hd,
+ (Some hd,
{ pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p);
pat = Some pat;
code = ERes_pf(c,{ce with env=empty_env}) })
end
| _ -> failwith "make_apply_entry"
-(* flags is (e,v) with e=true if eapply 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 *)
@@ -279,14 +323,14 @@ let make_resolves env sigma flags pri c =
if ents = [] then
errorlabstrm "Hint"
(pr_lconstr c ++ spc() ++
- (if fst flags then str"cannot be used as a hint."
+ (if pi1 flags then str"cannot be used as a hint."
else str "can be used as a hint only for eauto."));
ents
(* used to add an hypothesis to the local hint database *)
let make_resolve_hyp env sigma (hname,_,htyp) =
try
- [make_apply_entry env sigma (true, false) None
+ [make_apply_entry env sigma (true, true, false) None
(mkVar hname, htyp)]
with
| Failure _ -> []
@@ -294,23 +338,23 @@ let make_resolve_hyp env sigma (hname,_,htyp) =
(* REM : in most cases hintname = id *)
let make_unfold (ref, eref) =
- (ref,
+ (Some ref,
{ pri = 4;
pat = None;
code = Unfold_nth eref })
let make_extern pri pat tacast =
- let hdconstr = try_head_pattern pat in
+ let hdconstr = Option.map try_head_pattern pat in
(hdconstr,
{ pri=pri;
- pat = Some pat;
+ pat = pat;
code= Extern tacast })
let make_trivial env sigma c =
let t = hnf_constr env sigma (type_of env sigma c) in
- let hd = head_of_constr_reference (List.hd (head_constr t)) in
+ let hd = head_of_constr_reference (fst (head_constr t)) in
let ce = mk_clenv_from dummy_goal (c,t) in
- (hd, { pri=1;
+ (Some hd, { pri=1;
pat = Some (Pattern.pattern_of_constr (clenv_type ce));
code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) })
@@ -328,15 +372,29 @@ let add_hint dbname hintlist =
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 false) in
+ let db = Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false) in
searchtable_add (dbname,db)
-type hint_action = CreateDB of bool | UpdateDB of (global_reference * pri_auto_tactic) list
+let add_transparency dbname grs b =
+ let db = searchtable_map dbname in
+ let st = Hint_db.transparent_state db in
+ let st' =
+ List.fold_left (fun (ids, csts) gr ->
+ match gr with
+ | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts)
+ | EvalVarRef v -> (if b then Idpred.add else Idpred.remove) v ids, csts)
+ st grs
+ in searchtable_add (dbname, Hint_db.set_transparent_state db st')
+
+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)) =
match hints with
- | CreateDB b -> searchtable_add (name, Hint_db.empty b)
- | UpdateDB hints -> add_hint name hints
+ | 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 =
ref (fun _ -> failwith "subst_tactic is not installed for auto")
@@ -351,11 +409,15 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) =
code = code ;
}
in
- let subst_hint (lab,data as hint) =
- let lab',elab' = subst_global subst lab in
- let lab' =
- try head_of_constr_reference (List.hd (head_constr_bound elab' []))
- with Tactics.Bound -> lab' in
+ let subst_key gr =
+ let (lab'', elab') = subst_global subst gr in
+ let gr' =
+ (try head_of_constr_reference (fst (head_constr_bound elab'))
+ with Tactics.Bound -> lab'')
+ in if gr' == gr then gr else gr'
+ in
+ let subst_hint (k,data as hint) =
+ let k' = Option.smartmap subst_key k in
let data' = match data.code with
| Res_pf (c, clenv) ->
let c' = subst_mps subst c in
@@ -383,18 +445,21 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) =
if tac==tac' then data else
trans_data data (Extern tac')
in
- if lab' == lab && data' == data then hint else
- (lab',data')
+ if k' == k && data' == data then hint else
+ (k',data')
in
match hintlist with
| CreateDB _ -> obj
- | UpdateDB hintlist ->
+ | 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,UpdateDB hintlist')
+ (local,name,AddTactic hintlist')
let classify_autohint (_,((local,name,hintlist) as obj)) =
- if local or hintlist = (UpdateDB []) then Dispose else Substitute 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
@@ -408,8 +473,8 @@ let (inAutoHint,outAutoHint) =
export_function = export_autohint }
-let create_hint_db l n b =
- Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB b))
+let create_hint_db l n st b =
+ Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st)))
(**************************************************************************)
(* The "Hint" vernacular command *)
@@ -419,29 +484,40 @@ let add_resolves env sigma clist local dbnames =
(fun dbname ->
Lib.add_anonymous_leaf
(inAutoHint
- (local,dbname, UpdateDB
- (List.flatten (List.map (fun (x, y) ->
- make_resolves env sigma (true,Flags.is_verbose()) x y) clist)))))
+ (local,dbname, AddTactic
+ (List.flatten (List.map (fun (x, hnf, y) ->
+ make_resolves env sigma (true,hnf,Flags.is_verbose()) x y) clist)))))
dbnames
let add_unfolds l local dbnames =
List.iter
(fun dbname -> Lib.add_anonymous_leaf
- (inAutoHint (local,dbname, UpdateDB (List.map make_unfold l))))
+ (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
+ (inAutoHint (local,dbname, AddTransparency (l, b))))
dbnames
-let add_extern pri (patmetas,pat) tacast local dbname =
+let add_extern pri pat tacast local dbname =
(* We check that all metas that appear in tacast have at least
one occurence in the left pattern pat *)
let tacmetas = [] in
- match (list_subtract tacmetas patmetas) with
- | i::_ ->
- errorlabstrm "add_extern"
- (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound.")
- | [] ->
+ match pat with
+ | Some (patmetas,pat) ->
+ (match (list_subtract tacmetas patmetas) with
+ | i::_ ->
+ errorlabstrm "add_extern"
+ (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound.")
+ | [] ->
+ Lib.add_anonymous_leaf
+ (inAutoHint(local,dbname, AddTactic [make_extern pri (Some pat) tacast])))
+ | None ->
Lib.add_anonymous_leaf
- (inAutoHint(local,dbname, UpdateDB [make_extern pri pat tacast]))
+ (inAutoHint(local,dbname, AddTactic [make_extern pri None tacast]))
let add_externs pri pat tacast local dbnames =
List.iter (add_extern pri pat tacast local) dbnames
@@ -450,7 +526,7 @@ let add_trivials env sigma l local dbnames =
List.iter
(fun dbname ->
Lib.add_anonymous_leaf (
- inAutoHint(local,dbname, UpdateDB (List.map (make_trivial env sigma) l))))
+ inAutoHint(local,dbname, AddTactic (List.map (make_trivial env sigma) l))))
dbnames
let forward_intern_tac =
@@ -464,7 +540,7 @@ let add_hints local dbnames0 h =
let f = Constrintern.interp_constr sigma env in
match h with
| HintsResolve lhints ->
- add_resolves env sigma (List.map (fun (pri, x) -> pri, f x) lhints) local dbnames
+ 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 ->
@@ -478,21 +554,35 @@ let add_hints local dbnames0 h =
(str "Cannot coerce" ++ spc () ++ pr_global gr ++ spc () ++
str "to an evaluable reference.")
in
- if !Flags.dump then Constrintern.add_glob (loc_of_reference r) gr;
+ 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
| 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, mkConstruct (isp,i+1)) (Array.length consnames) in
+ (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
| HintsExtern (pri, patcom, tacexp) ->
- let pat = Constrintern.interp_constrpattern Evd.empty (Global.env()) patcom in
- let tacexp = !forward_intern_tac (fst pat) tacexp in
+ let pat = Option.map (Constrintern.intern_constr_pattern Evd.empty (Global.env())) patcom in
+ let tacexp = !forward_intern_tac (match pat with None -> [] | Some (l, _) -> l) tacexp in
add_externs pri pat tacexp local dbnames
| HintsDestruct(na,pri,loc,pat,code) ->
if dbnames0<>[] then
@@ -503,7 +593,7 @@ let add_hints local dbnames0 h =
(* Functions for printing the hints *)
(**************************************************************************)
-let fmt_autotactic =
+let pr_autotactic =
function
| Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c)
| ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c)
@@ -514,19 +604,19 @@ let fmt_autotactic =
| Extern tac ->
(str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac)
-let fmt_hint v =
- (fmt_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ())
+let pr_hint v =
+ (pr_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ())
-let fmt_hint_list hintlist =
- (str " " ++ hov 0 (prlist fmt_hint hintlist) ++ fnl ())
+let pr_hint_list hintlist =
+ (str " " ++ hov 0 (prlist pr_hint hintlist) ++ fnl ())
-let fmt_hints_db (name,db,hintlist) =
+let pr_hints_db (name,db,hintlist) =
(str "In the database " ++ str name ++ str ":" ++
if hintlist = [] then (str " nothing" ++ fnl ())
- else (fnl () ++ fmt_hint_list hintlist))
+ else (fnl () ++ pr_hint_list hintlist))
(* Print all hints associated to head c in any database *)
-let fmt_hint_list_for_head c =
+let pr_hint_list_for_head c =
let dbs = Hintdbmap.to_list !searchtable in
let valid_dbs =
map_succeed
@@ -538,19 +628,16 @@ let fmt_hint_list_for_head c =
else
hov 0
(str"For " ++ pr_global c ++ str" -> " ++ fnl () ++
- hov 0 (prlist fmt_hints_db valid_dbs))
+ hov 0 (prlist pr_hints_db valid_dbs))
-let fmt_hint_ref ref = fmt_hint_list_for_head ref
+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(fmt_hint_ref ref)
+let print_hint_ref ref = ppnl(pr_hint_ref ref)
-let fmt_hint_term cl =
+let pr_hint_term cl =
try
- let (hdc,args) = match head_constr_bound cl [] with
- | hdc::args -> (hdc,args)
- | [] -> assert false
- in
+ let (hdc,args) = head_constr_bound cl in
let hd = head_of_constr_reference hdc in
let dbs = Hintdbmap.to_list !searchtable in
let valid_dbs =
@@ -568,14 +655,14 @@ let fmt_hint_term cl =
(str "No hint applicable for current goal")
else
(str "Applicable Hints :" ++ fnl () ++
- hov 0 (prlist fmt_hints_db valid_dbs))
+ hov 0 (prlist pr_hints_db valid_dbs))
with Bound | 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 (fmt_hint_term cl)
+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 () =
@@ -591,9 +678,15 @@ let print_hint_db db =
str"Unfoldable constant definitions: " ++ pr_cpred csts ++ fnl ()));
Hint_db.iter
(fun head hintlist ->
- msg (hov 0
- (str "For " ++ pr_global head ++ str " -> " ++
- fmt_hint_list hintlist)))
+ match head with
+ | Some head ->
+ msg (hov 0
+ (str "For " ++ pr_global head ++ str " -> " ++
+ pr_hint_list hintlist))
+ | None ->
+ msg (hov 0
+ (str "For any goal -> " ++
+ pr_hint_list hintlist)))
db
let print_hint_db_by_name dbname =
@@ -618,7 +711,10 @@ let print_searchtable () =
(* tactics with a trace mechanism for automatic search *)
(**************************************************************************)
-let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l)
+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) *)
@@ -633,25 +729,33 @@ let auto_unif_flags = {
(* Try unification with the precompiled clause, then use registered Apply *)
-let unify_resolve_nodelta (c,clenv) gls =
- let clenv' = connect_clenv gls clenv in
- let _ = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gls in
- h_simplest_apply c gls
+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 unify_resolve flags (c,clenv) gls =
- let clenv' = connect_clenv gls clenv in
- let _ = clenv_unique_resolver false ~flags clenv' gls in
- h_apply true false [c,NoBindings] gls
+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 unify_resolve_gen = function
+ | None -> unify_resolve_nodelta
+ | Some flags -> unify_resolve flags
(* builds a hint database from a constr signature *)
(* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
-let make_local_hint_db eapply lems g =
- let sign = pf_hyps g in
- let hintlist = list_map_append (pf_apply make_resolve_hyp g) sign in
- let hintlist' = list_map_append (pf_apply make_resolves g (eapply,false) None) lems in
- Hint_db.add_list hintlist' (Hint_db.add_list hintlist (Hint_db.empty false))
+let add_hint_lemmas eapply lems hint_db gl =
+ let hintlist' =
+ list_map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in
+ Hint_db.add_list hintlist' hint_db
+
+let make_local_hint_db eapply lems gl =
+ let sign = pf_hyps gl in
+ let hintlist = list_map_append (pf_apply make_resolve_hyp gl) sign in
+ add_hint_lemmas eapply lems
+ (Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false)) gl
(* Serait-ce possible de compiler d'abord la tactique puis de faire la
substitution sans passer par bdize dont l'objectif est de préparer un
@@ -671,10 +775,13 @@ let forward_interp_tactic =
let set_extern_interp f = forward_interp_tactic := f
let conclPattern concl pat tac gl =
- let constr_bindings =
- try matches pat concl
- with PatternMatchingFailure -> error "conclPattern" in
- !forward_interp_tactic constr_bindings tac gl
+ let constr_bindings =
+ match pat with
+ | None -> []
+ | Some pat ->
+ try matches pat concl
+ with PatternMatchingFailure -> error "conclPattern" in
+ !forward_interp_tactic constr_bindings tac gl
(**************************************************************************)
(* The Trivial tactic *)
@@ -684,6 +791,10 @@ let conclPattern concl pat tac gl =
(* Papageno : cette fonction a été pas mal simplifiée depuis que la base
de Hint impérative a été remplacée par plusieurs bases fonctionnelles *)
+let flags_of_state st =
+ {auto_unif_flags with
+ modulo_conv_on_closed_terms = Some st; modulo_delta = st}
+
let rec trivial_fail_db mod_delta db_list local_db gl =
let intro_tac =
tclTHEN intro
@@ -697,29 +808,12 @@ let rec trivial_fail_db mod_delta db_list local_db gl =
(trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl
and my_find_search_nodelta db_list local_db hdc concl =
- let tacl =
- 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
- List.map
- (fun {pri=b; pat=p; code=t} ->
- (b,
- match t with
- | Res_pf (term,cl) -> unify_resolve_nodelta (term,cl)
- | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
- | Give_exact c -> exact_check c
- | Res_pf_THEN_trivial_fail (term,cl) ->
- tclTHEN
- (unify_resolve_nodelta (term,cl))
- (trivial_fail_db false db_list local_db)
- | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
- | Extern tacast ->
- conclPattern concl (Option.get p) tacast))
- tacl
+ if occur_existential concl then
+ List.map (fun hint -> (None,hint))
+ (list_map_append (Hint_db.map_all hdc) (local_db::db_list))
+ else
+ List.map (fun hint -> (None,hint))
+ (list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list))
and my_find_search mod_delta =
if mod_delta then my_find_search_delta
@@ -727,46 +821,51 @@ and my_find_search mod_delta =
and my_find_search_delta db_list local_db hdc concl =
let flags = {auto_unif_flags with use_metas_eagerly = true} in
- let tacl =
if occur_existential concl then
list_map_append
(fun db ->
- let st = {flags with modulo_delta = Hint_db.transparent_state db} in
- List.map (fun x -> (st,x)) (Hint_db.map_all hdc 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)) (Hint_db.map_auto (hdc,concl) db)
+ else
+ let flags = {flags with modulo_delta = Hint_db.transparent_state db} in
+ List.map (fun x -> (Some flags,x)) (Hint_db.map_all hdc db))
(local_db::db_list)
else
list_map_append (fun db ->
- let (ids, csts as st) = Hint_db.transparent_state db in
- let st, l =
- let l =
- if (Idpred.is_empty ids && Cpred.is_empty csts)
- then Hint_db.map_auto (hdc,concl) db
- else Hint_db.map_all hdc db
- in {flags with modulo_delta = st}, l
- in List.map (fun x -> (st,x)) l)
+ 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)) (Hint_db.map_auto (hdc,concl) db)
+ else
+ let (ids, csts as st) = Hint_db.transparent_state db in
+ let flags, l =
+ let l =
+ if (Idpred.is_empty ids && Cpred.is_empty csts)
+ then Hint_db.map_auto (hdc,concl) db
+ else Hint_db.map_all hdc db
+ in {flags with modulo_delta = st}, l
+ in List.map (fun x -> (Some flags,x)) l)
(local_db::db_list)
- in
- List.map
- (fun (st, {pri=b; pat=p; code=t}) ->
- (b,
- match t with
- | Res_pf (term,cl) -> unify_resolve st (term,cl)
- | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
- | Give_exact c -> exact_check c
- | Res_pf_THEN_trivial_fail (term,cl) ->
- tclTHEN
- (unify_resolve st (term,cl))
- (trivial_fail_db true db_list local_db)
- | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
- | Extern tacast ->
- conclPattern concl (Option.get p) tacast))
- tacl
+
+and tac_of_hint db_list local_db concl (flags, {pat=p; code=t}) =
+ match t with
+ | Res_pf (term,cl) -> unify_resolve_gen flags (term,cl)
+ | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
+ | Give_exact c -> exact_check c
+ | Res_pf_THEN_trivial_fail (term,cl) ->
+ 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]
+ | Extern tacast -> conclPattern concl p tacast
and trivial_resolve mod_delta db_list local_db cl =
try
- let hdconstr = List.hd (head_constr_bound cl []) in
- priority
- (my_find_search mod_delta db_list local_db (head_of_constr_reference hdconstr) cl)
+ let hdconstr,_ = head_constr_bound cl in
+ List.map (tac_of_hint db_list local_db cl)
+ (priority
+ (my_find_search mod_delta db_list local_db
+ (head_of_constr_reference hdconstr) cl))
with Bound | Not_found ->
[]
@@ -804,70 +903,82 @@ let h_trivial lems l =
let possible_resolve mod_delta db_list local_db cl =
try
- let hdconstr = List.hd (head_constr_bound cl []) in
- List.map snd
- (my_find_search mod_delta db_list local_db (head_of_constr_reference hdconstr) cl)
+ let hdconstr,_ = head_constr_bound cl in
+ List.map (tac_of_hint db_list local_db cl)
+ (my_find_search mod_delta db_list local_db
+ (head_of_constr_reference hdconstr) cl)
with Bound | Not_found ->
[]
-let decomp_unary_term c gls =
- let typc = pf_type_of gls c in
- let hd = List.hd (head_constr typc) in
- if Hipattern.is_conjunction hd then
- simplest_case c gls
- else
- errorlabstrm "Auto.decomp_unary_term" (str "Not a unary type.")
-
-let decomp_empty_term c gls =
- let typc = pf_type_of gls c in
- let (hd,_) = decompose_app typc in
- if Hipattern.is_empty_type hd then
- simplest_case c gls
+let decomp_unary_term_then (id,_,typc) kont1 kont2 gl =
+ try
+ let ccl = applist (head_constr typc) in
+ match Hipattern.match_with_conjunction ccl with
+ | Some (_,args) ->
+ tclTHEN (simplest_case (mkVar id)) (kont1 (List.length args)) gl
+ | None ->
+ 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
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 *)
+
+let rec decomp_and_register_decl p kont (id,_,_ as decl) db gl =
+ if p = 0 then
+ kont (extend_local_db gl decl db) gl
+ else
+ tclORELSE0
+ (decomp_empty_term decl)
+ (decomp_unary_term_then decl (intros_decomp (p-1) kont [] db)
+ (kont (extend_local_db gl decl db))) gl
+
+(* Introduce [n] hypotheses, then decompose then with maximum depth [p] and
+ call the continuation tactic [kont] with the hint db extended
+ with the so-obtained not-further-decomposable hypotheses *)
+
+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 ->
+ (intros_decomp p kont (d::decls) db (n-1))))
+
+(* Decompose hypotheses [hyps] with maximum depth [p] and
+ call the continuation tactic [kont] with the hint db extended
+ with the so-obtained not-further-decomposable hypotheses *)
+
+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
of conjunction in hypotheses, 0 corresponds to no decomposition *)
(* n is the max depth of search *)
(* local_db contains the local Hypotheses *)
-let rec search_gen decomp n mod_delta db_list local_db extra_sign goal =
- if n=0 then error "BOUND 2";
- let decomp_tacs = match decomp with
- | 0 -> []
- | p ->
- (tclTRY_sign decomp_empty_term extra_sign)
- ::
- (List.map
- (fun id -> tclTHENSEQ
- [decomp_unary_term (mkVar id);
- clear [id];
- search_gen decomp p mod_delta db_list local_db []])
- (pf_ids_of_hyps goal))
- in
- let intro_tac =
- tclTHEN intro
- (fun g' ->
- let (hid,_,htyp as d) = pf_last_hyp g' in
- let hintl =
- try
- [make_apply_entry (pf_env g') (project g')
- (true,false) None
- (mkVar hid, htyp)]
- with Failure _ -> []
- in
- search_gen decomp n mod_delta db_list (Hint_db.add_list hintl local_db) [d] g')
- in
- let rec_tacs =
- List.map
- (fun ntac ->
- tclTHEN ntac
- (search_gen decomp (n-1) mod_delta db_list local_db empty_named_context))
- (possible_resolve mod_delta db_list local_db (pf_concl goal))
- in
- tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal
+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
+ in
+ search n local_db
let search = search_gen 0
@@ -883,8 +994,7 @@ let delta_auto mod_delta n lems dbnames gl =
error_no_such_hint_database x)
("core"::dbnames)
in
- let hyps = pf_hyps gl in
- tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl) hyps) gl
+ tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl
let auto = delta_auto false
@@ -896,8 +1006,7 @@ 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
- let hyps = pf_hyps gl in
- tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl) hyps) gl
+ tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl
let full_auto = delta_full_auto false
let new_full_auto = delta_full_auto true
@@ -922,14 +1031,15 @@ let h_auto n lems l =
(* Depth of search after decomposition of hypothesis, by default
one look for an immediate solution *)
-(* Papageno : de toute façon un paramète > 1 est traité comme 1 pour
- l'instant *)
-let default_search_decomp = ref 1
-
-let destruct_auto des_opt lems n gl =
- let hyps = pf_hyps gl in
- search_gen des_opt n false (List.map searchtable_map ["core";"extcore"])
- (make_local_hint_db false lems gl) hyps gl
+let default_search_decomp = ref 20
+
+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)
@@ -952,7 +1062,7 @@ let make_resolve_any_hyp env sigma (id,_,ty) =
let ents =
map_succeed
(fun f -> f (mkVar id,ty))
- [make_exact_entry None; make_apply_entry env sigma (true,false) None]
+ [make_exact_entry None; make_apply_entry env sigma (true,true,false) None]
in
ents
@@ -988,25 +1098,23 @@ let compileAutoArg contac = function
let compileAutoArgList contac = List.map (compileAutoArg contac)
-let rec super_search n db_list local_db argl goal =
+let rec super_search n db_list local_db argl gl =
if n = 0 then error "BOUND 2";
tclFIRST
(assumption
::
- (tclTHEN intro
+ 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))
+ argl g)
::
- ((List.map
- (fun 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 goal)))
+ (possible_resolve false db_list local_db (pf_concl gl))
@
- (compileAutoArgList
- (super_search (n-1) db_list local_db argl) argl))) goal
+ compileAutoArgList (super_search (n-1) db_list local_db argl) argl) gl
let search_superauto n to_add argl g =
let sigma =
diff --git a/tactics/auto.mli b/tactics/auto.mli
index edaaa1c1..c9065ef3 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 11282 2008-07-28 11:51:53Z msozeau $ i*)
+(*i $Id: auto.mli 11735 2009-01-02 17:22:31Z herbelin $ i*)
(*i*)
open Util
@@ -44,20 +44,24 @@ type stored_data = pri_auto_tactic
type search_entry = stored_data list * stored_data list * stored_data Btermdn.t
+(* The head may not be bound. *)
+
+type hint_entry = global_reference option * pri_auto_tactic
+
module Hint_db :
sig
type t
- val empty : bool -> t
+ val empty : transparent_state -> bool -> t
val find : global_reference -> t -> search_entry
val map_all : global_reference -> t -> pri_auto_tactic list
val map_auto : global_reference * constr -> t -> pri_auto_tactic list
- val add_one : global_reference * pri_auto_tactic -> t -> t
- val add_list : (global_reference * pri_auto_tactic) list -> t -> t
- val iter : (global_reference -> stored_data list -> unit) -> t -> unit
+ val add_one : hint_entry -> t -> t
+ val add_list : (hint_entry) list -> t -> t
+ val iter : (global_reference option -> stored_data list -> unit) -> t -> unit
+ val use_dn : t -> bool
val transparent_state : t -> transparent_state
val set_transparent_state : t -> transparent_state -> t
- val set_rigid : t -> constant -> t
end
type hint_db_name = string
@@ -68,7 +72,12 @@ val searchtable_map : hint_db_name -> hint_db
val searchtable_add : (hint_db_name * hint_db) -> unit
-val create_hint_db : bool -> hint_db_name -> bool -> unit
+(* [create_hint_db local name st use_dn].
+ [st] is a transparency state for unification using this db
+ [use_dn] switches the use of the discrimination net for all hints
+ and patterns. *)
+
+val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit
val current_db_names : unit -> hint_db_name list
@@ -86,16 +95,18 @@ val print_hint_db_by_name : hint_db_name -> unit
[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 -> global_reference * pri_auto_tactic
+val make_exact_entry : 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
+ products;
[c] is the term given as an exact proof to solve the goal;
- [cty] is the type of [hc]. *)
-
+ [cty] is the type of [c]. *)
+
val make_apply_entry :
- env -> evar_map -> bool * bool -> int option -> constr * constr
- -> global_reference * pri_auto_tactic
+ env -> evar_map -> bool * bool * bool -> int option -> constr * constr
+ -> hint_entry
(* A constr which is Hint'ed will be:
(1) used as an Exact, if it does not start with a product
@@ -105,8 +116,8 @@ val make_apply_entry :
has missing arguments. *)
val make_resolves :
- env -> evar_map -> bool * bool -> int option -> constr ->
- (global_reference * pri_auto_tactic) list
+ env -> evar_map -> bool * bool * bool -> int option -> constr ->
+ hint_entry list
(* [make_resolve_hyp hname htyp].
used to add an hypothesis to the local hint database;
@@ -114,14 +125,13 @@ val make_resolves :
If the hyp cannot be used as a Hint, the empty list is returned. *)
val make_resolve_hyp :
- env -> evar_map -> named_declaration ->
- (global_reference * pri_auto_tactic) list
+ env -> evar_map -> named_declaration -> hint_entry list
(* [make_extern pri pattern tactic_expr] *)
val make_extern :
- int -> constr_pattern -> Tacexpr.glob_tactic_expr
- -> global_reference * pri_auto_tactic
+ int -> constr_pattern option -> Tacexpr.glob_tactic_expr
+ -> hint_entry
val set_extern_interp :
(patvar_map -> Tacexpr.glob_tactic_expr -> tactic) -> unit
@@ -140,7 +150,7 @@ val set_extern_subst_tactic :
val make_local_hint_db : bool -> constr list -> goal sigma -> hint_db
-val priority : (int * 'a) list -> 'a list
+val priority : ('a * pri_auto_tactic) list -> ('a * pri_auto_tactic) list
val default_search_depth : int ref
@@ -156,7 +166,7 @@ val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic
[Pattern.somatches], then replace [?1] [?2] metavars in tacast by the
right values to build a tactic *)
-val conclPattern : constr -> constr_pattern -> Tacexpr.glob_tactic_expr -> tactic
+val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> tactic
(* The Auto tactic *)
@@ -192,7 +202,7 @@ val gen_trivial : constr list -> hint_db_name list option -> tactic
val full_trivial : constr list -> tactic
val h_trivial : constr list -> hint_db_name list option -> tactic
-val fmt_autotactic : auto_tactic -> Pp.std_ppcmds
+val pr_autotactic : auto_tactic -> Pp.std_ppcmds
(*s The following is not yet up to date -- Papageno. *)
diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4
index 6eb5e359..e609fb77 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 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: class_tactics.ml4 11823 2009-01-21 15:32:37Z msozeau $ *)
open Pp
open Util
@@ -43,7 +43,8 @@ open Evd
let default_eauto_depth = 100
let typeclasses_db = "typeclass_instances"
-let _ = Auto.auto_init := (fun () -> Auto.create_hint_db false typeclasses_db false)
+let _ = Auto.auto_init := (fun () ->
+ Auto.create_hint_db false typeclasses_db full_transparent_state true)
let check_imported_library d =
let d' = List.map id_of_string d in
@@ -60,26 +61,20 @@ let init_setoid () =
(** Typeclasses instance search tactic / eauto *)
-let evars_of_term init 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 init c
-
let intersects s t =
Intset.exists (fun el -> Intset.mem el t) s
open Auto
-let e_give_exact c gl =
+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 t1) (exact_check c) gl
- else exact_check c gl
-
-let assumption id = e_give_exact (mkVar id)
+ 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 assumption flags id = e_give_exact flags (mkVar id)
open Unification
@@ -89,19 +84,21 @@ let auto_unif_flags = {
modulo_delta = var_full_transparent_state;
}
-let unify_e_resolve st (c,clenv) gls =
+let unify_e_resolve flags (c,clenv) gls =
let clenv' = connect_clenv gls clenv in
- let clenv' = clenv_unique_resolver false
- ~flags:{auto_unif_flags with modulo_delta = st} clenv' gls
+ let clenv' = clenv_unique_resolver false ~flags clenv' gls
in
- Clenvtac.clenv_refine true clenv' gls
+ Clenvtac.clenv_refine true ~with_classes:false clenv' gls
-let unify_resolve st (c,clenv) gls =
+let unify_resolve flags (c,clenv) gls =
let clenv' = connect_clenv gls clenv in
- let clenv' = clenv_unique_resolver false
- ~flags:{auto_unif_flags with modulo_delta = st} clenv' gls
+ let clenv' = clenv_unique_resolver false ~flags clenv' gls
in
- Clenvtac.clenv_refine false clenv' gls
+ Clenvtac.clenv_refine false ~with_classes:false clenv' gls
+
+let flags_of_state st =
+ {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 =
@@ -119,47 +116,43 @@ let rec e_trivial_fail_db db_list local_db goal =
and e_my_find_search db_list local_db hdc concl =
let hdc = head_of_constr_reference hdc in
let hintl =
- if occur_existential concl then
- list_map_append
- (fun db ->
- let st = Hint_db.transparent_state db in
- List.map (fun x -> (st, x)) (Hint_db.map_all hdc db))
- (local_db::db_list)
- else
- list_map_append
- (fun db ->
- let st = Hint_db.transparent_state db in
- List.map (fun x -> (st, x)) (Hint_db.map_auto (hdc,concl) db))
- (local_db::db_list)
+ list_map_append
+ (fun db ->
+ if Hint_db.use_dn db then
+ let flags = flags_of_state (Hint_db.transparent_state db) in
+ List.map (fun x -> (flags, x)) (Hint_db.map_auto (hdc,concl) db)
+ else
+ let flags = flags_of_state (Hint_db.transparent_state db) in
+ List.map (fun x -> (flags, x)) (Hint_db.map_all hdc db))
+ (local_db::db_list)
in
let tac_of_hint =
- fun (st, {pri=b; pat = p; code=t}) ->
+ fun (flags, {pri=b; pat = p; code=t}) ->
let tac =
match t with
- | Res_pf (term,cl) -> unify_resolve st (term,cl)
- | ERes_pf (term,cl) -> unify_e_resolve st (term,cl)
- | Give_exact (c) -> e_give_exact c
+ | Res_pf (term,cl) -> unify_resolve flags (term,cl)
+ | ERes_pf (term,cl) -> unify_e_resolve flags (term,cl)
+ | Give_exact (c) -> e_give_exact flags c
| Res_pf_THEN_trivial_fail (term,cl) ->
- tclTHEN (unify_e_resolve st (term,cl))
+ tclTHEN (unify_e_resolve flags (term,cl))
(e_trivial_fail_db db_list local_db)
| Unfold_nth c -> unfold_in_concl [all_occurrences,c]
- | Extern tacast -> conclPattern concl
- (Option.get p) tacast
+ | Extern tacast -> conclPattern concl p tacast
in
- (tac,b,fmt_autotactic t)
+ (tac,b,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
- (List.hd (head_constr_bound gl [])) gl
+ (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
- (List.hd (head_constr_bound gl [])) gl
+ (fst (head_constr_bound gl)) gl
with Bound | Not_found -> []
let find_first_goal gls =
@@ -184,14 +177,14 @@ let rec catchable = function
| e -> Logic.catchable_exception e
let is_dep gl gls =
- let evs = evars_of_term Intset.empty gl.evar_concl in
+ let evs = Evarutil.evars_of_term gl.evar_concl in
if evs = Intset.empty then false
else
List.fold_left
(fun b gl ->
if b then b
else
- let evs' = evars_of_term Intset.empty gl.evar_concl in
+ let evs' = Evarutil.evars_of_term gl.evar_concl in
intersects evs evs')
false gls
@@ -210,7 +203,7 @@ module SearchProblem = struct
prlist (pr_ev evars) (sig_it gls)
let filter_tactics (glls,v) l =
- let glls,nv = apply_tac_list tclNORMEVAR glls in
+ let glls,nv = apply_tac_list Refiner.tclNORMEVAR glls in
let v p = v (nv p) in
let rec aux = function
| [] -> []
@@ -243,37 +236,35 @@ module SearchProblem = struct
[]
else
let (cut, do_cut, ldb as hdldb) = List.hd s.localdb in
- if !cut then []
+ 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
- Option.iter (fun r -> r := true) do_cut;
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 sigma = Evarutil.nf_evars sigma in
+ let gl = List.map (Evarutil.nf_evar_info sigma) gl in
let nbgl = List.length gl in
- let g = { it = List.hd gl ; sigma = sigma } 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 (Evarutil.nf_evar_info sigma (List.hd gl)) (List.tl gl)) then
+ if not (is_dep (List.hd gl) (List.tl gl)) then
let fresh = ref false in
- if do' = None then
+ 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
- (cut', None, ldb), tl
+ ) 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 assumption_tacs =
- let l =
- filter_tactics s.tacres
- (List.map
- (fun id -> (Eauto.e_give_exact_constr (mkVar id), 0,
- (str "exact" ++ spc () ++ pr_id id)))
- (List.filter (fun id -> filter_hyp (pf_get_hyp_typ g id))
- (pf_ids_of_hyps g)))
- in
- List.map (fun (res,pri,pp) -> { s with tacres = res; pri = 0;
- last_tactic = pp; localdb = List.tl s.localdb }) l
- in
let intro_tac =
List.map
(fun ((lgls,_) as res,pri,pp) ->
@@ -300,14 +291,13 @@ module SearchProblem = struct
last_tactic = pp; pri = pri;
localdb = list_tabulate (fun _ -> new_db) (nbgl'-nbgl) @ localdb }
in
- let concl = Evarutil.nf_evar (project g) (pf_concl g) in
let rec_tacs =
let l =
- filter_tactics s.tacres (e_possible_resolve s.dblist ldb concl)
+ 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 (assumption_tacs @ intro_tac @ rec_tacs)
+ List.sort compare (intro_tac @ rec_tacs)
end
let pp s =
@@ -318,46 +308,6 @@ end
module Search = Explore.Make(SearchProblem)
-
-let filter_pat c =
- try
- let morg = Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism")) in
- let morc = constr_of_global morg in
- match kind_of_term c with
- | App(morph, [| t; r; m |]) when eq_constr morph morc ->
- (fun y ->
- (match y.pat with
- Some (PApp (PRef mor, [| t'; r'; m' |])) when mor = morg ->
- (match m' with
- | PRef c -> if isConst m then eq_constr (constr_of_global c) m else false
- | _ -> true)
- | _ -> true))
- | _ -> fun _ -> true
- with _ -> fun _ -> true
-
-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 filter c =
- try let morc = constr_of_global (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism"))) in
- match kind_of_term c with
- | App(morph, [| t; r; m |]) when eq_constr morph morc ->
- (fun y ->
- let (_, r) = decompose_prod y in
- (match kind_of_term r with
- App (morph', [| t'; r'; m' |]) when eq_constr morph' morc ->
- (match kind_of_term m' with
- | Rel n -> true
- | Const c -> eq_constr m m'
- | App _ -> true
- | _ -> false)
- | _ -> false))
- | _ -> fun _ -> true
- with _ -> fun _ -> true
-
let make_initial_state n gls dblist localdbs =
{ depth = n;
tacres = gls;
@@ -379,11 +329,39 @@ let e_breadth_search debug s =
in let s = tac s in s.tacres
with Not_found -> error "eauto: breadth first search failed."
+
+(* A special one for getting everything into a dnet. *)
+
+let is_transparent_gr (ids, csts) = function
+ | VarRef id -> Idpred.mem id ids
+ | ConstRef cst -> Cpred.mem cst csts
+ | IndRef _ | ConstructRef _ -> false
+
+let make_resolve_hyp env sigma st flags pri (id, _, cty) =
+ 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
+ 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]
+ 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 true lems ({it = gl; sigma = sigma}) in
- (ref false, None, Hint_db.set_transparent_state db st)) gls' in
+ 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
@@ -394,7 +372,8 @@ 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
- e_search_auto debug n lems empty_transparent_state db_list gls
+ let db = searchtable_map typeclasses_db in
+ e_search_auto debug n lems (Hint_db.transparent_state db) db_list gls
let nf_goal (gl, valid) =
{ gl with sigma = Evarutil.nf_evars gl.sigma }, valid
@@ -415,16 +394,23 @@ let valid goals p res_sigma l =
else sigma)
!res_sigma goals l
in raise (Found evm)
+
+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) ->
+ (fun ev evi (gls, evm') ->
if evi.evar_body = Evar_empty
&& Typeclasses.is_resolvable evi
- && p ev evi then ((ev,evi) :: gls, Evd.add evm ev (Typeclasses.mark_unresolvable evi)) else
- (gls, Evd.add evm ev 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
@@ -463,7 +449,7 @@ let rec merge_deps deps = function
let split_evars evm =
Evd.fold (fun ev evi acc ->
- let deps = evars_of_term (Intset.singleton ev) evi.evar_concl in
+ let deps = Intset.union (Intset.singleton ev) (Evarutil.evars_of_term evi.evar_concl) in
merge_deps deps acc)
evm []
@@ -501,7 +487,7 @@ let resolve_all_evars debug m env p oevd do_split fail =
(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 then
+ if not b (* || do_split *) then
true, Some ev
else b, None
else b, acc) evm (false, None)
@@ -528,35 +514,36 @@ let _ =
VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings
-| [ "Typeclasses" "unfold" reference_list(cl) ] -> [
- add_hints false [typeclasses_db] (Vernacexpr.HintsUnfold cl)
+| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [
+ add_hints false [typeclasses_db] (Vernacexpr.HintsTransparency (cl, true))
]
END
-
+
VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings
-| [ "Typeclasses" "rigid" reference_list(cl) ] -> [
- let db = searchtable_map typeclasses_db in
- let db' =
- List.fold_left (fun acc r ->
- let gr = Syntax_def.global_with_alias r in
- match gr with
- | ConstRef c -> Hint_db.set_rigid acc c
- | _ -> acc) db cl
- in
- searchtable_add (typeclasses_db,db')
- ]
+| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [
+ add_hints false [typeclasses_db] (Vernacexpr.HintsTransparency (cl, false))
+ ]
END
(** Typeclass-based rewriting. *)
-let respect_proj = lazy (mkConst (snd (List.hd (Lazy.force morphism_class).cl_projs)))
+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_reference dir s =
+let try_find_global_reference dir s =
let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in
- constr_of_global (Nametab.absolute_reference sp)
-
+ 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")
@@ -565,23 +552,28 @@ 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 ["Program"; "Basics"] "id")
+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")
@@ -592,6 +584,8 @@ let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultR
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")
@@ -638,8 +632,6 @@ let split_head = function
hd :: tl -> hd, tl
| [] -> assert(false)
-exception DependentMorphism
-
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
@@ -656,21 +648,28 @@ let build_signature isevars env m (cstrs : 'a option list) (finalcstr : 'a Lazy.
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) ty then raise DependentMorphism;
- let (b, arg, evars) = aux (Environ.push_rel (na, None, ty) env) b cstrs in
- let ty = Reductionops.nf_betaiota ty in
- let relty = mk_relty ty obj in
- let arg' = mkApp (Lazy.force respectful, [| ty ; b ; relty ; arg |]) in
- mkProd(na, ty, b), arg', (ty, relty) :: evars
+ 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 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 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 ty in
let rel = mk_relty t None in
- t, rel, [t, rel]
+ t, rel, [t, Some rel]
| Some codom -> let (t, rel) = Lazy.force codom in
- t, rel, [t, rel])
+ t, rel, [t, Some rel])
in aux env m cstrs
let morphism_proof env evars carrier relation x =
@@ -678,18 +677,15 @@ let morphism_proof env evars carrier relation x =
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 carrier relation =
+let find_class_proof proof_type proof_method env evars carrier relation =
try
- let goal =
- mkApp (Lazy.force proof_type, [| carrier ; relation |])
- in
- let inst = resolve_one_typeclass env goal in
- mkApp (Lazy.force proof_method, [| carrier ; relation ; inst |])
+ 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 reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
-let symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
-let transitive_proof env = find_class_proof transitive_type transitive_proof env
+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
@@ -711,28 +707,29 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars
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
- let proj =
- mkApp (Lazy.force respect_proj,
- Array.append cl_args [|morph|])
- in
- morph, proj, sigargs, appm, morphobjs, morphobjs'
+ 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 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')
+ 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, r ] -> (proof, (a, r, oldt, fnewt newt))
+ [ a, Some r ] -> (proof, (a, r, oldt, fnewt newt))
| _ -> assert(false)
(* Adapted from setoid_replace. *)
@@ -755,24 +752,32 @@ let evd_convertible env evd x y =
let decompose_setoid_eqhyp env sigma c left2right =
let ctype = Typing.type_of env sigma c in
- let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ctype) 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
+ 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
- if not (evd_convertible env eqclause.evd ty1 ty2) then
- error "The term does not end with an applied homogeneous relation."
- else
- { 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 }
-
+ 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;
@@ -798,32 +803,19 @@ let refresh_hypinfo env sigma hypinfo =
match c with
| Some c ->
(* Refresh the clausenv to not get the same meta twice in the goal. *)
- hypinfo := decompose_setoid_eqhyp cl.env (Evd.evars_of cl.evd) c l2r;
+ hypinfo := decompose_setoid_eqhyp env (Evd.evars_of cl.evd) c l2r;
| _ -> ()
else ()
let unify_eqn env sigma hypinfo t =
- try
+ 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) ->
- (*if convertible env cl.evd left t then
- cl, prf, c1, c2, car, rel
- else raise Not_found*)
let env' = 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 c1 = Clenv.clenv_nf_meta env' c1
- and c2 = Clenv.clenv_nf_meta env' c2
- and car = Clenv.clenv_nf_meta env' car
- and rel = Clenv.clenv_nf_meta env' rel in
- hypinfo := { !hypinfo with
- cl = env';
- abs = Some (Clenv.clenv_value env', Clenv.clenv_type env') };
env', prf, c1, c2, car, rel
| None ->
let env' =
@@ -838,7 +830,7 @@ let unify_eqn env sigma hypinfo t =
let mvs = clenv_dependent false env' in
clenv_pose_metas_as_evars env' mvs
in
- let evd' = Typeclasses.resolve_typeclasses env'.env env'.evd 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
@@ -855,11 +847,11 @@ let unify_eqn env sigma hypinfo t =
let res =
if l2r then (prf, (car, rel, c1, c2))
else
- try (mkApp (symmetric_proof env car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1))
+ 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 _ -> None
+ with e when catchable e -> None
let unfold_impl t =
match kind_of_term t with
@@ -1041,16 +1033,18 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g
| None -> pf_concl gl, None
in
let cstr =
- match is_hyp with
- None -> (mkProp, inverse mkProp (Lazy.force impl))
- | Some _ -> (mkProp, Lazy.force impl)
+ let sort = mkProp in
+ let impl = Lazy.force impl in
+ match is_hyp with
+ | None -> (sort, inverse sort impl)
+ | Some _ -> (sort, impl)
in
- let evars = ref (Evd.create_evar_defs Evd.empty) in
- let env = pf_env gl 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
+ match eq with
| Some (p, (_, _, oldt, newt)) ->
(try
evars := Typeclasses.resolve_typeclasses env ~split:false ~fail:true !evars;
@@ -1069,22 +1063,22 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g
mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
in
cut_replacing id newt
- (fun x -> Tactics.refine (mkApp (term, [| mkVar id |])))
+ (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]) (Tactics.refine p))
+ (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p))
| Some (t, ty) ->
- Tactics.refine
+ 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 evartac =
let evd = Evd.evars_of undef in
if not (evd = Evd.empty) then Refiner.tclEVARS (Evd.merge sigma evd)
else tclIDTAC
@@ -1104,8 +1098,7 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g
(* tclFAIL 1 (str"setoid rewrite failed") gl *)
let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause gl =
- try cl_rewrite_clause_aux ~flags hypinfo goal_meta occs clause gl
- with DependentMorphism -> tclFAIL 0 (str " setoid rewrite failed: cannot handle dependent morphisms") gl
+ cl_rewrite_clause_aux ~flags hypinfo goal_meta occs clause gl
let cl_rewrite_clause (evm,c) left2right occs clause gl =
init_setoid ();
@@ -1113,10 +1106,6 @@ let cl_rewrite_clause (evm,c) left2right occs clause gl =
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 c = *)
-(* let j = Pretyping.Default.understand_judgment_tcc evars env c in *)
-(* j.Environ.uj_val *)
-(* in *)
let hypinfo = ref (decompose_setoid_eqhyp env evars c left2right) in
cl_rewrite_clause_aux hypinfo meta occs clause gl
@@ -1248,9 +1237,7 @@ let declare_an_instance n s args =
let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
let anew_instance binders instance fields =
- new_instance binders instance fields
- ~on_free_vars:Classes.fail_on_free_vars
- None
+ 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
@@ -1259,17 +1246,17 @@ let require_library dirpath =
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)]
+ [((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)]
+ [((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)]
+ [((dummy_loc,id_of_string "transitivity"),lemma)]
let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None)))
@@ -1294,16 +1281,16 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans =
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)])
+ [((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)])
+ [((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
@@ -1311,9 +1298,9 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans =
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)])
+ [((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
@@ -1456,8 +1443,10 @@ let build_morphism_signature m =
let t', sig_, evars = build_signature isevars env t cstrs None snd in
let _ = List.iter
(fun (ty, rel) ->
- let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in
- ignore (Evarutil.e_new_evar isevars env default))
+ 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 =
@@ -1473,8 +1462,7 @@ let default_morphism sign m =
let isevars = ref (Evd.create_evar_defs Evd.empty) in
let t = Typing.type_of env Evd.empty m in
let _, sign, evars =
- try build_signature isevars env t (fst sign) (snd sign) (fun (ty, rel) -> rel)
- with DependentMorphism -> error "Cannot infer the signature of dependent morphisms"
+ build_signature isevars env t (fst sign) (snd sign) (fun (ty, rel) -> rel)
in
let morph =
mkApp (Lazy.force morphism_type, [| t; sign; m |])
@@ -1490,16 +1478,14 @@ let add_setoid binders a aeq t n =
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])])
+ [((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 = try build_morphism_signature m
- with DependentMorphism -> error "Cannot infer the signature of dependent morphisms"
- 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)
@@ -1513,7 +1499,8 @@ let add_morphism_infer m n =
Command.start_proof instance_id kind instance
(fun _ -> function
Libnames.ConstRef cst ->
- add_instance (Typeclasses.new_instance (Lazy.force morphism_class) None false 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>>)) ();
@@ -1529,10 +1516,8 @@ let add_morphism binders m s n =
[cHole; s; m]))
in
let tac = Tacinterp.interp <:tactic<add_morphism_tactic>> in
- ignore(new_instance binders instance []
- ~on_free_vars:Classes.fail_on_free_vars
- ~tac ~hook:(fun cst -> declare_projection n instance_id (ConstRef cst))
- None)
+ 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) ] ->
@@ -1573,62 +1558,59 @@ let check_evar_map_of_evars_defs evd =
) metas
let unification_rewrite l2r c1 c2 cl car rel but gl =
- let (env',c') =
+ 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 (pf_env gl) ((if l2r then c1 else c2),but) cl.evd
+ 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
- (pf_env gl) ((if l2r then c1 else c2),but) cl.evd
+ 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 cl' = {cl with evd = env'} in
- let c1 = Clenv.clenv_nf_meta cl' c1
- and c2 = Clenv.clenv_nf_meta cl' c2 in
- check_evar_map_of_evars_defs env';
- let prf = Clenv.clenv_value cl' in
- let prfty = Clenv.clenv_type cl' 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 c clause l2r =
- let hi = decompose_setoid_eqhyp (pf_env gl) (project gl) c l2r in
+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 l2r occs c ~new_goals gl =
+let general_s_rewrite cl l2r occs c ~new_goals gl =
let meta = Evarutil.new_meta() in
- let hypinfo = ref (get_hyp gl c None l2r) in
- cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs None gl
-
-let general_s_rewrite_in id l2r occs c ~new_goals gl =
- let meta = Evarutil.new_meta() in
- let hypinfo = ref (get_hyp gl c (Some id) l2r) in
- cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs (Some (([],id), [])) gl
+ 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
- | Some id -> general_s_rewrite_in id
+ | None -> general_s_rewrite None
+ | Some id -> general_s_rewrite (Some id)
let _ = Equality.register_general_setoid_rewrite_clause general_s_rewrite_clause
-(* [setoid_]{reflexivity,symmetry,transitivity} tactics *)
-
-let relation_of_constr 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
- | _ -> error "Not an applied relation."
-
let is_loaded d =
let d' = List.map id_of_string d in
let dir = make_dirpath (List.rev d') in
@@ -1637,36 +1619,175 @@ let is_loaded d =
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 setoid_reflexivity 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 rel, args = relation_of_constr (pf_concl gl) in
- try
- apply (reflexive_proof env (pf_type_of gl args.(0)) rel) gl
- with Not_found ->
- tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared reflexive relation")
- gl
-
-let setoid_symmetry gl =
+ 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 rel, args = relation_of_constr (pf_concl gl) in
- try
- apply (symmetric_proof env (pf_type_of gl args.(0)) rel) gl
- with Not_found ->
- tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared symmetric relation")
- gl
+ 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 import 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_transitivity c gl =
+let setoid_proof gl ty fn fallback =
let env = pf_env gl in
- let rel, args = relation_of_constr (pf_concl gl) in
- try
+ 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
- ((transitive_proof env (pf_type_of gl args.(0)) rel),
- Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ]) gl
- with Not_found ->
- tclFAIL 0
- (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared transitive relation") gl
-
+ ((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
@@ -1696,49 +1817,11 @@ TACTIC EXTEND setoid_symmetry
END
TACTIC EXTEND setoid_reflexivity
- [ "setoid_reflexivity" ] -> [ setoid_reflexivity ]
+[ "setoid_reflexivity" ] -> [ setoid_reflexivity ]
END
TACTIC EXTEND setoid_transitivity
- [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ]
-END
-
-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
-
-let constrexpr = Pcoq.Tactic.open_constr
-type 'a constr_expr_argtype = (open_constr_expr, 'a) Genarg.abstract_argument_type
-
-let (wit_constrexpr : Genarg.tlevel constr_expr_argtype),
- (globwit_constrexpr : Genarg.glevel constr_expr_argtype),
- (rawwit_const_expr : Genarg.rlevel constr_expr_argtype) =
- Genarg.create_arg "constrexpr"
-
-open Environ
-open Refiner
-
-TACTIC EXTEND apply_typeclasses
- [ "typeclass_app" raw(t) ] -> [ fun gl ->
- let nprod = nb_prod (pf_concl gl) in
- 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
- let n = nb_prod j.uj_type - nprod in
- if n<0 then error "Apply_tc: theorem has not enough premisses.";
- Refiner.tclTHEN (Refiner.tclEVARS (Evd.evars_of !evars))
- (fun gl ->
- let clause = make_clenv_binding_apply gl (Some n) (j.uj_val,j.uj_type) NoBindings 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
- Clenvtac.clenv_refine true {cl' with evd = evd'} gl) gl
- ]
+[ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ]
END
let rec head_of_constr t =
@@ -1752,6 +1835,105 @@ let rec head_of_constr t =
TACTIC EXTEND head_of_constr
[ "head_of_constr" ident(h) constr(c) ] -> [
let c = head_of_constr c in
- letin_tac None (Name h) c allHyps
+ letin_tac None (Name h) c None allHyps
+ ]
+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)
]
END
+
+
diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml
index 97225617..c99884c0 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 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id: decl_interp.ml 11576 2008-11-10 19:13:15Z msozeau $ i*)
open Util
open Names
@@ -94,8 +94,10 @@ let rec add_vars_of_simple_pattern globs = function
(UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here"))
| CPatDelimiters (_,_,p) ->
add_vars_of_simple_pattern globs p
- | CPatCstr (_,_,pl) | CPatNotation(_,_,pl) ->
+ | CPatCstr (_,_,pl) ->
List.fold_left add_vars_of_simple_pattern globs pl
+ | CPatNotation(_,_,(pl,pll)) ->
+ List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll))
| CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs
| _ -> globs
@@ -342,7 +344,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
(fun (loc,(id,_)) ->
RVar (loc,id)) params in
let dum_args=
- list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark false))
+ list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false)))
oib.Declarations.mind_nrealargs in
raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in
let pat_vars,aliases,patt = interp_pattern env pat in
diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml
index 5356868a..839a494a 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 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: decl_proof_instr.ml 11671 2008-12-12 12:43:03Z herbelin $ *)
open Util
open Pp
@@ -107,7 +107,7 @@ let clean_tmp gls =
clean_all (tmp_ids gls) gls
let assert_postpone id t =
- assert_as true (dummy_loc, Genarg.IntroIdentifier id) t
+ assert_tac (Name id) t
(* start a proof *)
@@ -264,7 +264,7 @@ let add_justification_hyps keep items 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 Tacexpr.nowhere)
+ tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere)
(thin_body [id]) gls in
tclMAP add_aux items gls
@@ -780,7 +780,7 @@ let consider_tac c hyps gls =
| _ ->
let id = pf_get_new_id (id_of_string "_tmp") gls in
tclTHEN
- (forward None (dummy_loc, Genarg.IntroIdentifier id) c)
+ (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c)
(consider_match false [] [id] hyps) gls
@@ -811,7 +811,7 @@ let rec build_function args body =
let define_tac id args body gls =
let t = build_function args body in
- letin_tac None (Name id) t Tacexpr.nowhere gls
+ letin_tac None (Name id) t None Tacexpr.nowhere gls
(* tactics for reconsider *)
diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli
index 2e235a01..877c8047 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 10739 2008-04-01 14:45:20Z herbelin $ *)
+(* $Id: decl_proof_instr.mli 11481 2008-10-20 19:23:51Z herbelin $ *)
open Refiner
open Names
diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml
index 14731b26..f3e1559f 100644
--- a/tactics/dhyp.ml
+++ b/tactics/dhyp.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: dhyp.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: dhyp.ml 11739 2009-01-02 19:33:19Z herbelin $ *)
(* Chet's comments about this tactic :
@@ -131,6 +131,7 @@ open Pattern
open Matching
open Pcoq
open Tacexpr
+open Termops
open Libnames
(* two patterns - one for the type, and one for the type of the type *)
@@ -248,7 +249,7 @@ 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.interp_constrpattern Evd.empty (Global.env()) pat
+ let (_,pat) = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat
in
let pat = match loc with
| HypLocation b ->
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index 1503ca9a..67bdeb46 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: eauto.ml4 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: eauto.ml4 11735 2009-01-02 17:22:31Z herbelin $ *)
open Pp
open Util
@@ -31,9 +31,9 @@ open Auto
open Rawterm
open Hiddentac
-let e_give_exact c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in
+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
- tclTHEN (Clenvtac.unify t1) (exact_check c) gl
+ tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl
else exact_check c gl
let assumption id = e_give_exact (mkVar id)
@@ -91,6 +91,8 @@ open Unification
(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *)
(***************************************************************************)
+let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l)
+
(* no delta yet *)
let unify_e_resolve flags (c,clenv) gls =
@@ -140,12 +142,11 @@ and e_my_find_search_nodelta db_list local_db hdc concl =
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
- (Option.get p) tacast
+ | Extern tacast -> conclPattern concl p tacast
in
- (tac,fmt_autotactic t))
+ (tac,pr_autotactic t))
(*i
- fun gls -> pPNL (fmt_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";
@@ -174,17 +175,16 @@ and e_my_find_search_delta db_list local_db hdc concl =
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_constr c
+ | Give_exact (c) -> e_give_exact ~flags:st 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]
- | Extern tacast -> conclPattern concl
- (Option.get p) tacast
+ | Extern tacast -> conclPattern concl p tacast
in
- (tac,fmt_autotactic t))
+ (tac,pr_autotactic t))
(*i
- fun gls -> pPNL (fmt_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";
@@ -196,15 +196,15 @@ and e_my_find_search_delta db_list local_db hdc concl =
and e_trivial_resolve mod_delta db_list local_db gl =
try
- Auto.priority
+ priority
(e_my_find_search mod_delta db_list local_db
- (List.hd (head_constr_bound gl [])) gl)
+ (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
- (List.hd (head_constr_bound gl [])) gl)
+ (fst (head_constr_bound gl)) gl)
with Bound | Not_found -> []
let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id))
@@ -460,3 +460,9 @@ TACTIC EXTEND autosimpl
| [ "autosimpl" hintbases(db) ] ->
[ autosimpl (match db with None -> ["core"] | Some x -> "core"::x) None ]
END
+
+TACTIC EXTEND unify
+| ["unify" constr(x) constr(y) ] -> [ unify x y ]
+| ["unify" constr(x) constr(y) "with" preident(base) ] -> [
+ unify ~state:(Hint_db.transparent_state (searchtable_map base)) x y ]
+END
diff --git a/tactics/elim.ml b/tactics/elim.ml
index 55df0f0a..fa4a7caa 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: elim.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: elim.ml 11739 2009-01-02 19:33:19Z herbelin $ *)
open Pp
open Util
@@ -128,7 +128,7 @@ let decompose_nonrec c gls =
let decompose_and c gls =
general_decompose
- (fun (_,t) -> is_conjunction t)
+ (fun (_,t) -> is_record t)
c gls
let decompose_or c gls =
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 7fb19423..ba18430a 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: equality.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: equality.ml 11800 2009-01-18 18:34:15Z msozeau $ *)
open Pp
open Util
@@ -37,12 +37,12 @@ open Tacred
open Rawterm
open Coqlib
open Vernacexpr
-open Setoid_replace
open Declarations
open Indrec
open Printer
open Clenv
open Clenvtac
+open Evd
(* Rewriting tactics *)
@@ -55,25 +55,22 @@ open Clenvtac
*)
(* Ad hoc asymmetric general_elim_clause *)
-let general_elim_clause with_evars cls c elim =
+let general_elim_clause with_evars cls sigma c l elim =
try
(match cls with
| None ->
(* was tclWEAK_PROGRESS which only fails for tactics generating one
subgoal and did not fail for useless conditional rewritings generating
an extra condition *)
- tclNOTSAMEGOAL (general_elim with_evars c elim ~allow_K:false)
+ tclNOTSAMEGOAL (tclTHEN (Refiner.tclEVARS sigma)
+ (general_elim with_evars (c,l) elim ~allow_K:false))
| Some id ->
- general_elim_in with_evars id c elim)
+ tclTHEN (Refiner.tclEVARS sigma) (general_elim_in with_evars id (c,l) elim))
with Pretype_errors.PretypeError (env,
(Pretype_errors.NoOccurrenceFound (c', _))) ->
raise (Pretype_errors.PretypeError
(env, (Pretype_errors.NoOccurrenceFound (c', cls))))
-let elimination_sort_of_clause = function
- | None -> elimination_sort_of_goal
- | Some id -> elimination_sort_of_hyp id
-
(* 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
@@ -81,11 +78,7 @@ let elimination_sort_of_clause = function
If occurrences are set, use setoid_rewrite.
*)
-let general_s_rewrite_clause = function
- | None -> general_s_rewrite
- | Some id -> general_s_rewrite_in id
-
-let general_setoid_rewrite_clause = ref general_s_rewrite_clause
+let general_setoid_rewrite_clause = ref (fun _ -> assert false)
let register_general_setoid_rewrite_clause = (:=) general_setoid_rewrite_clause
let is_applied_setoid_relation = ref (fun _ -> false)
@@ -96,39 +89,52 @@ let is_applied_relation t =
| App (c, args) when Array.length args >= 2 -> true
| _ -> false
-let leibniz_rewrite_ebindings_clause cls lft2rgt (c,l) with_evars gl hdcncl =
- let hdcncls = string_of_inductive hdcncl in
- let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in
- let dir = if cls=None then lft2rgt else not lft2rgt in
- let rwr_thm = if dir then hdcncls^suffix^"_r" else hdcncls^suffix in
- let elim =
- try pf_global gl (id_of_string rwr_thm)
- with Not_found ->
- error ("Cannot find rewrite principle "^rwr_thm^".")
- in general_elim_clause with_evars cls (c,l) (elim,NoBindings) gl
+(* find_elim determines which elimination principle is necessary to
+ eliminate lbeq on sort_of_gl. *)
-let leibniz_eq = Lazy.lazy_from_fun build_coq_eq
+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 adjust_rewriting_direction args lft2rgt =
+ if List.length args = 1 then
+ (* equality to a constant, like in eq_true *)
+ (* more natural to see -> as the rewriting to the constant *)
+ not lft2rgt
+ else
+ (* other equality *)
+ lft2rgt
-let general_rewrite_ebindings_clause cls lft2rgt occs (c,l) with_evars gl =
+let general_rewrite_ebindings_clause cls lft2rgt occs ((c,l) : open_constr with_bindings) with_evars gl =
if occs <> all_occurrences then (
!general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl)
else
- let ctype = pf_apply get_type_of gl c in
let env = pf_env gl in
- let sigma = project 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 ctype) in
- match match_with_equation t with
- | Some (hdcncl,_) -> (* Fast path: direct leibniz rewrite *)
- leibniz_rewrite_ebindings_clause cls lft2rgt (c,l) with_evars gl hdcncl
+ match match_with_equality_type t with
+ | Some (hdcncl,args) -> (* Fast path: direct leibniz rewrite *)
+ let lft2rgt = adjust_rewriting_direction args lft2rgt in
+ leibniz_rewrite_ebindings_clause cls lft2rgt sigma c' l with_evars 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_equation t' with
- | Some (hdcncl,_) -> (* Maybe a setoid relation with eq inside *)
+ 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 (c,l) with_evars gl hdcncl
+ (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)
@@ -140,7 +146,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs (c,l) with_evars gl =
let general_rewrite_ebindings =
general_rewrite_ebindings_clause None
let general_rewrite_bindings l2r occs (c,bl) =
- general_rewrite_ebindings_clause None l2r occs (c,inj_ebindings 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
@@ -148,9 +154,9 @@ let general_rewrite l2r occs c =
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 (c,inj_ebindings 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 (c,NoBindings)
+ general_rewrite_ebindings_clause (Some id) l2r occs (inj_open c,NoBindings)
let general_multi_rewrite l2r with_evars c cl =
let occs_of = on_snd (List.fold_left
@@ -186,7 +192,7 @@ let general_multi_rewrite l2r with_evars c cl =
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()) (fst c) in
+ let ids_in_c = Environ.global_vars_set (Global.env()) (snd (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
@@ -262,10 +268,10 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl =
let e = build_coq_eq () in
let sym = build_coq_sym_eq () in
let eq = applist (e, [t1;c1;c2]) in
- tclTHENS (assert_tac false Anonymous eq)
+ tclTHENS (assert_as false None eq)
[onLastHyp (fun id ->
tclTHEN
- (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause))
+ (tclTRY (general_multi_rewrite false false (inj_open (mkVar id),NoBindings) clause))
(clear [id]));
tclFIRST
[assumption;
@@ -450,7 +456,8 @@ let injectable env sigma t1 t2 =
let descend_then sigma env head dirn =
let IndType (indf,_) =
try find_rectype env sigma (get_type_of env sigma head)
- with Not_found -> assert false in
+ with Not_found ->
+ error "Cannot project on an inductive type derived from a dependency." in
let ind,_ = dest_ind_family indf in
let (mib,mip) = lookup_mind_specif env ind in
let cstr = get_constructors env indf in
@@ -470,7 +477,7 @@ let descend_then sigma env head dirn =
(interval 1 (Array.length mip.mind_consnames)) in
let ci = make_case_info env ind RegularStyle in
mkCase (ci, p, head, Array.of_list brl)))
-
+
(* Now we need to construct the discriminator, given a discriminable
position. This boils down to:
@@ -819,11 +826,14 @@ let make_iterated_tuple env sigma dflt (z,zty) =
let rec build_injrec sigma env dflt c = function
| [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c)
| ((sp,cnum),argnum)::l ->
+ try
let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in
let newc = mkRel(cnum_nlams-argnum) in
let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in
(kont subval (dfltval,tuplety),
- tuplety,dfltval)
+ tuplety,dfltval)
+ with
+ UserError _ -> failwith "caught"
let build_injector sigma env dflt c cpath =
let (injcode,resty,_) = build_injrec sigma env dflt c cpath in
@@ -978,26 +988,11 @@ let swapEquandsInHyp id gls =
cut_replacing id (swap_equands gls (pf_get_hyp_typ gls id))
(tclTHEN swapEquandsInConcl) gls
-(* find_elim determines which elimination principle is necessary to
- eliminate lbeq on sort_of_gl.
- This is somehow an artificial choice as we could take eq_rect in
- all cases (eq_ind - and eq_rec - are instances of eq_rect) [HH 2/4/06].
-*)
-
-let find_elim sort_of_gl lbeq =
- match kind_of_term sort_of_gl with
- | Sort(Prop Null) (* Prop *) -> lbeq.ind
- | _ (* Set/Type *) ->
- (match lbeq.rect with
- | Some eq_rect -> eq_rect
- | None -> errorlabstrm "find_elim"
- (str "This type of substitution is not allowed."))
-
(* 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 (pf_apply get_type_of gls (pf_concl gls)) lbeq in
+ let eq_elim = find_elim lbeq.eq false None gls in
(* build substitution predicate *)
let p = lambda_create (pf_env gls) (t,body) in
(* apply substitution scheme *)
@@ -1050,14 +1045,16 @@ let subst_tuple_term env sigma dep_pair b =
let abst_B =
List.fold_right
(fun (e,t) body -> lambda_create env (t,subst_term e body)) e_list b in
- applist(abst_B,proj_list)
-
+ beta_applist(abst_B,proj_list)
+
(* Comme "replace" mais decompose les egalites dependantes *)
+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
- assert (dependent (mkRel 1) body);
+ if not (dependent (mkRel 1) body) then raise NothingToRewrite;
bareRevSubstInConcl lbeq body eq gls
(* |- (P e1)
@@ -1075,7 +1072,7 @@ 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
- assert (dependent (mkRel 1) body);
+ if not (dependent (mkRel 1) body) then raise NothingToRewrite;
cut_replacing id (subst1 e2 body)
(tclTHENFIRST (bareRevSubstInConcl lbeq body eq)) gls
@@ -1095,6 +1092,9 @@ let try_rewrite tac gls =
| e when catchable_exception e ->
errorlabstrm "try_rewrite"
(strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.")
+ | NothingToRewrite ->
+ errorlabstrm "try_rewrite"
+ (strbrk "Nothing to rewrite.")
let cutSubstClause l2r eqn cls gls =
match cls with
@@ -1113,33 +1113,22 @@ let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls)
let rewriteInHyp l2r c id = rewriteClause l2r c (Some id)
let rewriteInConcl l2r c = rewriteClause l2r c None
-(* Renaming scheme correspondence new name (old name)
+(* Naming scheme for rewrite and cutrewrite tactics
- give equality give proof of equality
+ give equality give proof of equality
- / cutSubstClause (subst) substClause (HypSubst on hyp)
-raw | cutSubstInHyp (substInHyp) substInHyp (none)
- \ cutSubstInConcl (substInConcl) substInConcl (none)
+ / cutSubstClause substClause
+raw | cutSubstInHyp substInHyp
+ \ cutSubstInConcl substInConcl
- / cutRewriteClause (none) rewriteClause (none)
-user| cutRewriteInHyp (substHyp) rewriteInHyp (none)
- \ cutRewriteInConcl (substConcl) rewriteInConcl (substHypInConcl on hyp)
+ / cutRewriteClause rewriteClause
+user| cutRewriteInHyp rewriteInHyp
+ \ cutRewriteInConcl rewriteInConcl
raw = raise typing error or PatternMatchingFailure
user = raise user error specific to rewrite
*)
-(* Summary of obsolete forms
-let substInConcl = cutSubstInConcl
-let substInHyp = cutSubstInHyp
-let hypSubst l2r id = substClause l2r (mkVar id)
-let hypSubst_LR = hypSubst true
-let hypSubst_RL = hypSubst false
-let substHypInConcl l2r id = rewriteInConcl l2r (mkVar id)
-let substConcl = cutRewriteInConcl
-let substHyp = cutRewriteInHyp
-*)
-
(**********************************************************************)
(* Substitutions tactics (JCF) *)
@@ -1211,8 +1200,8 @@ let subst_one x gl =
(id,None,_) -> intro_using id
| (id,Some hval,htyp) ->
letin_tac None (Name id)
- (mkCast(replace_term varx rhs hval,DEFAULTcast,
- replace_term varx rhs htyp)) nowhere
+ (replace_term varx rhs hval)
+ (Some (replace_term varx rhs htyp)) nowhere
in
let need_rewrite = dephyps <> [] || depconcl in
tclTHENLIST
@@ -1273,7 +1262,7 @@ let rewrite_multi_assumption_cond cond_eq_term cl gl =
begin
try
let dir = cond_eq_term t gl in
- general_multi_rewrite dir false (mkVar id,NoBindings) cl gl
+ general_multi_rewrite dir false (inj_open (mkVar id),NoBindings) cl gl
with | Failure _ | UserError _ -> arec rest
end
in
@@ -1333,14 +1322,4 @@ let replace_term_in_right t hyp = replace_multi_term (Some false) t (Tacticals.o
let replace_term_in t hyp = replace_multi_term None t (Tacticals.onHyp hyp)
-
-
-
-
-
-
-
-
-let _ = Setoid_replace.register_replace (fun tac_opt c2 c1 gl -> replace_in_clause_maybe_by c2 c1 onConcl tac_opt gl)
-let _ = Setoid_replace.register_general_rewrite general_rewrite
let _ = Tactics.register_general_multi_rewrite general_multi_rewrite
diff --git a/tactics/equality.mli b/tactics/equality.mli
index f05ebc6c..86ad3293 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 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id: equality.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
(*i*)
open Util
@@ -45,7 +45,7 @@ val rewriteRL : constr -> tactic
val register_general_setoid_rewrite_clause :
(identifier option -> bool ->
- occurrences -> constr -> new_goals:constr list -> tactic) -> unit
+ occurrences -> open_constr -> new_goals:constr list -> tactic) -> unit
val register_is_applied_setoid_relation : (constr -> bool) -> unit
val general_rewrite_bindings_in :
@@ -54,14 +54,14 @@ val general_rewrite_in :
bool -> occurrences -> identifier -> constr -> evars_flag -> tactic
val general_multi_rewrite :
- bool -> evars_flag -> constr with_ebindings -> clause -> tactic
+ bool -> evars_flag -> open_constr with_bindings -> clause -> tactic
val general_multi_multi_rewrite :
- evars_flag -> (bool * multi * constr with_ebindings) list -> clause ->
+ evars_flag -> (bool * multi * open_constr with_bindings) list -> clause ->
tactic option -> tactic
-val conditional_rewrite : bool -> tactic -> constr with_ebindings -> tactic
+val conditional_rewrite : bool -> tactic -> open_constr with_bindings -> tactic
val conditional_rewrite_in :
- bool -> identifier -> tactic -> constr with_ebindings -> tactic
+ bool -> identifier -> tactic -> open_constr with_bindings -> tactic
val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic
val replace : constr -> constr -> tactic
diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml
index 3c266c51..43c18a8b 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 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: evar_tactics.ml 11576 2008-11-10 19:13:15Z msozeau $ *)
open Term
open Util
@@ -75,5 +75,5 @@ 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'))
- (Tactics.letin_tac None name evar nowhere) gls
+ (Tactics.letin_tac None name evar None nowhere) gls
diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli
index dbf7db31..cc06d2c6 100644
--- a/tactics/evar_tactics.mli
+++ b/tactics/evar_tactics.mli
@@ -6,11 +6,12 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: evar_tactics.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+(*i $Id: evar_tactics.mli 11512 2008-10-27 12:28:36Z herbelin $ i*)
open Tacmach
open Names
open Tacexpr
+open Termops
val instantiate : int -> Rawterm.rawconstr ->
(identifier * hyp_location_flag, unit) location -> tactic
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
index a0230b28..694c3495 100644
--- a/tactics/extraargs.ml4
+++ b/tactics/extraargs.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: extraargs.ml4 11094 2008-06-10 19:35:23Z herbelin $ *)
+(* $Id: extraargs.ml4 11800 2009-01-18 18:34:15Z msozeau $ *)
open Pp
open Pcoq
@@ -16,6 +16,7 @@ open Genarg
open Names
open Tacexpr
open Tacinterp
+open Termops
(* Rewriting orientation *)
@@ -97,22 +98,6 @@ ARGUMENT EXTEND occurrences
| [ var(id) ] -> [ ArgVar id ]
END
-(* For Setoid rewrite *)
-let pr_morphism_signature _ _ _ s =
- spc () ++ Setoid_replace.pr_morphism_signature s
-
-ARGUMENT EXTEND morphism_signature
- TYPED AS morphism_signature
- PRINTED BY pr_morphism_signature
- | [ constr(out) ] -> [ [],out ]
- | [ constr(c) "++>" morphism_signature(s) ] ->
- [ let l,out = s in (Some true,c)::l,out ]
- | [ constr(c) "-->" morphism_signature(s) ] ->
- [ let l,out = s in (Some false,c)::l,out ]
- | [ constr(c) "==>" morphism_signature(s) ] ->
- [ let l,out = s in (None,c)::l,out ]
-END
-
let pr_gen prc _prlc _prtac c = prc c
let pr_rawc _prc _prlc _prtac raw = Printer.pr_rawconstr raw
@@ -288,7 +273,7 @@ let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause =
Option.map
(fun l ->
List.map
- (fun id -> ( (all_occurrences_expr,trad_id id) ,Tacexpr.InHyp))
+ (fun id -> ( (all_occurrences_expr,trad_id id),InHyp))
l
)
hyps;
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
index 74296ab0..bccb150f 100644
--- a/tactics/extraargs.mli
+++ b/tactics/extraargs.mli
@@ -6,13 +6,14 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: extraargs.mli 10820 2008-04-20 18:18:49Z msozeau $ i*)
+(*i $Id: extraargs.mli 11800 2009-01-18 18:34:15Z msozeau $ i*)
open Tacexpr
open Term
open Names
open Proof_type
open Topconstr
+open Termops
open Rawterm
val rawwit_orient : bool raw_abstract_argument_type
@@ -23,13 +24,6 @@ val occurrences : (int list or_var) Pcoq.Gram.Entry.e
val rawwit_occurrences : (int list or_var) raw_abstract_argument_type
val wit_occurrences : (int list) typed_abstract_argument_type
-val rawwit_morphism_signature :
- Setoid_replace.morphism_signature raw_abstract_argument_type
-val wit_morphism_signature :
- Setoid_replace.morphism_signature typed_abstract_argument_type
-val morphism_signature :
- Setoid_replace.morphism_signature Pcoq.Gram.Entry.e
-
val rawwit_raw : constr_expr raw_abstract_argument_type
val wit_raw : rawconstr typed_abstract_argument_type
val raw : constr_expr Pcoq.Gram.Entry.e
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index 66716acd..ee01f839 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: extratactics.ml4 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: extratactics.ml4 11800 2009-01-18 18:34:15Z msozeau $ *)
open Pp
open Pcoq
@@ -18,6 +18,7 @@ open Mod_subst
open Names
open Tacexpr
open Rawterm
+open Tactics
(* Equality *)
open Equality
@@ -133,10 +134,10 @@ 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) 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) c ]
+ -> [ conditional_rewrite_in b h (snd tac) (inj_open (fst c), snd c) ]
END
TACTIC EXTEND dependent_rewrite
@@ -216,87 +217,6 @@ END
let refine_tac = h_refine
-(* Setoid_replace *)
-
-open Setoid_replace
-
-(* TACTIC EXTEND setoid_replace *)
-(* [ "setoid_replace" constr(c1) "with" constr(c2) by_arg_tac(tac)] -> *)
-(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:[] ] *)
-(* | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) by_arg_tac(tac)] -> *)
-(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:[] ] *)
-(* | [ "setoid_replace" constr(c1) "with" constr(c2) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] -> *)
-(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:l ] *)
-(* | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] -> *)
-(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:l ] *)
-(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) by_arg_tac(tac) ] -> *)
-(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:[] ] *)
-(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) by_arg_tac(tac)] -> *)
-(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:[] ] *)
-(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] -> *)
-(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:l ] *)
-(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] -> *)
-(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:l ] *)
-(* END *)
-
-(* TACTIC EXTEND setoid_rewrite *)
-(* [ "setoid_rewrite" orient(b) constr(c) ] *)
-(* -> [ general_s_rewrite b c ~new_goals:[] ] *)
-(* | [ "setoid_rewrite" orient(b) constr(c) "generate" "side" "conditions" constr_list(l) ] *)
-(* -> [ general_s_rewrite b c ~new_goals:l ] *)
-(* | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) ] -> *)
-(* [ general_s_rewrite_in h b c ~new_goals:[] ] *)
-(* | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] -> *)
-(* [ general_s_rewrite_in h b c ~new_goals:l ] *)
-(* END *)
-
-(* VERNAC COMMAND EXTEND AddSetoid1 *)
-(* [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> *)
-(* [ add_setoid n a aeq t ] *)
-(* | [ "Add" "Morphism" constr(m) ":" ident(n) ] -> *)
-(* [ new_named_morphism n m None ] *)
-(* | [ "Add" "Morphism" constr(m) "with" "signature" morphism_signature(s) "as" ident(n) ] -> *)
-(* [ new_named_morphism n m (Some s)] *)
-(* END *)
-
-(* VERNAC COMMAND EXTEND AddRelation1 *)
-(* [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "as" ident(n) ] -> *)
-(* [ add_relation n a aeq (Some t) (Some t') None ] *)
-(* | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "as" ident(n) ] -> *)
-(* [ add_relation n a aeq (Some t) None None ] *)
-(* | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> *)
-(* [ add_relation n a aeq None None None ] *)
-(* END *)
-
-(* VERNAC COMMAND EXTEND AddRelation2 *)
-(* [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "as" ident(n) ] -> *)
-(* [ add_relation n a aeq None (Some t') None ] *)
-(* | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'') "as" ident(n) ] -> *)
-(* [ add_relation n a aeq None (Some t') (Some t'') ] *)
-(* END *)
-
-(* VERNAC COMMAND EXTEND AddRelation3 *)
-(* [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "transitivity" "proved" "by" constr(t') "as" ident(n) ] -> *)
-(* [ add_relation n a aeq (Some t) None (Some t') ] *)
-(* | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'') "as" ident(n) ] -> *)
-(* [ add_relation n a aeq (Some t) (Some t') (Some t'') ] *)
-(* | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(t) "as" ident(n) ] -> *)
-(* [ add_relation n a aeq None None (Some t) ] *)
-(* END *)
-
-(* TACTIC EXTEND setoid_symmetry *)
-(* [ "setoid_symmetry" ] -> [ setoid_symmetry ] *)
-(* | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] *)
-(* END *)
-
-(* TACTIC EXTEND setoid_reflexivity *)
-(* [ "setoid_reflexivity" ] -> [ setoid_reflexivity ] *)
-(* END *)
-
-(* TACTIC EXTEND setoid_transitivity *)
-(* [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ] *)
-(* END *)
-
(* Inversion lemmas (Leminv) *)
open Inv
@@ -485,17 +405,6 @@ END
-TACTIC EXTEND apply_in
-| ["apply" ne_constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] ->
- [ apply_in false id cl ]
-END
-
-
-TACTIC EXTEND eapply_in
-| ["eapply" ne_constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] ->
- [ apply_in true id cl ]
-END
-
(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as
defined by Conor McBride *)
TACTIC EXTEND generalize_eqs
@@ -505,8 +414,8 @@ TACTIC EXTEND generalize_eqs_vars
| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize id ~generalize_vars:true ]
END
-TACTIC EXTEND conv
-| ["conv" constr(x) constr(y) ] -> [ conv x y ]
+TACTIC EXTEND dependent_pattern
+| ["dependent_pattern" constr(c) ] -> [ dependent_pattern c ]
END
TACTIC EXTEND resolve_classes
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
index 31c1b02f..b270ba2d 100644
--- a/tactics/hiddentac.ml
+++ b/tactics/hiddentac.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: hiddentac.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: hiddentac.ml 11671 2008-12-12 12:43:03Z herbelin $ *)
open Term
open Proof_type
@@ -39,9 +39,12 @@ 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)
-let h_apply simple ev cb =
- abstract_tactic (TacApply (simple,ev,List.map inj_open_wb cb))
+let h_apply simple ev cb =
+ abstract_tactic (TacApply (simple,ev,cb,None))
(apply_with_ebindings_gen simple ev cb)
+let h_apply_in simple ev cb (id,ipat as inhyp) =
+ abstract_tactic (TacApply (simple,ev,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))
(elim ev cb cbo)
@@ -71,7 +74,7 @@ let h_generalize_dep c =
abstract_tactic (TacGeneralizeDep (inj_open 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 cl)
+ abstract_tactic (TacLetTac (na,inj_open c,cl,b)) (letin_tac with_eq na c None cl)
let h_instantiate n c ido =
(Evar_tactics.instantiate n c ido)
(* abstract_tactic (TacInstantiate (n,c,cls))
@@ -131,8 +134,8 @@ let h_symmetry c = abstract_tactic (TacSymmetry c) (intros_symmetry c)
let h_transitivity c =
abstract_tactic (TacTransitivity (inj_open c)) (intros_transitivity c)
-let h_simplest_apply c = h_apply false false [c,NoBindings]
-let h_simplest_eapply c = h_apply false true [c,NoBindings]
+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_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 3e636668..0ebb024a 100644
--- a/tactics/hiddentac.mli
+++ b/tactics/hiddentac.mli
@@ -1,3 +1,4 @@
+
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: hiddentac.mli 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id: hiddentac.mli 11671 2008-12-12 12:43:03Z herbelin $ i*)
(*i*)
open Names
@@ -19,6 +20,7 @@ open Tacexpr
open Rawterm
open Evd
open Clenv
+open Termops
(*i*)
(* Tactics for the interpreter. They left a trace in the proof tree
@@ -36,7 +38,10 @@ val h_exact_no_check : constr -> tactic
val h_vm_cast_no_check : constr -> tactic
val h_apply : advanced_flag -> evars_flag ->
- constr with_ebindings list -> tactic
+ open_constr with_bindings list -> tactic
+val h_apply_in : advanced_flag -> evars_flag ->
+ open_constr with_bindings list ->
+ identifier * intro_pattern_expr located option -> tactic
val h_elim : evars_flag -> constr with_ebindings ->
constr with_ebindings option -> tactic
diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4
index de500f89..2e83ac70 100644
--- a/tactics/hipattern.ml4
+++ b/tactics/hipattern.ml4
@@ -8,13 +8,14 @@
(*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*)
-(* $Id: hipattern.ml4 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: hipattern.ml4 11739 2009-01-02 19:33:19Z herbelin $ *)
open Pp
open Util
open Names
open Nameops
open Term
+open Sign
open Termops
open Reductionops
open Inductiveops
@@ -64,43 +65,107 @@ let match_with_non_recursive_type t =
let is_non_recursive_type t = op2bool (match_with_non_recursive_type t)
-(* A general conjunction type is a non-recursive inductive type with
- only one constructor. *)
+(* Test dependencies *)
-let match_with_conjunction t =
- let (hdapp,args) = decompose_app t in
- match kind_of_term hdapp with
- | Ind ind ->
- let (mib,mip) = Global.lookup_inductive ind in
- if (Array.length mip.mind_consnames = 1)
- && (not (mis_is_recursive (ind,mib,mip)))
- && (mip.mind_nrealargs = 0)
- then
- Some (hdapp,args)
- else
- None
- | _ -> None
+let rec has_nodep_prod_after n c =
+ match kind_of_term c with
+ | 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
+ type with only one constructor and no dependencies between argument;
+ it is strict if it has the form
+ "Inductive I A1 ... An := C (_:A1) ... (_:An)" *)
-let is_conjunction t = op2bool (match_with_conjunction t)
-
-(* A general disjunction type is a non-recursive inductive type all
- whose constructors have a single argument. *)
+(* style: None = record; Some false = conjunction; Some true = strict conj *)
-let match_with_disjunction t =
+let match_with_one_constructor style t =
let (hdapp,args) = decompose_app t in
match kind_of_term hdapp with
- | Ind ind ->
- let car = mis_constr_nargs ind in
- if array_for_all (fun ar -> ar = 1) car &&
- (let (mib,mip) = Global.lookup_inductive ind in
- not (mis_is_recursive (ind,mib,mip)))
- then
- Some (hdapp,args)
- else
- None
- | _ -> None
+ | Ind ind ->
+ let (mib,mip) = Global.lookup_inductive ind in
+ if (Array.length mip.mind_consnames = 1)
+ && (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
+ (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in
+ if
+ List.for_all
+ (fun (_,b,c) -> b=None && c = mkRel mib.mind_nparams) ctx
+ then
+ Some (hdapp,args)
+ else None
+ else
+ let ctyp = prod_applist mip.mind_nf_lc.(0) args in
+ let cargs = List.map pi3 (fst (decompose_prod_assum ctyp)) in
+ if style <> Some false || has_nodep_prod ctyp then
+ (* Record or non strict conjunction *)
+ Some (hdapp,List.rev cargs)
+ else
+ None
+ else
+ None
+ | _ -> None
+
+let match_with_conjunction ?(strict=false) t =
+ match_with_one_constructor (Some strict) t
+
+let match_with_record t =
+ match_with_one_constructor None t
+
+let is_conjunction ?(strict=false) t =
+ op2bool (match_with_conjunction ~strict t)
+
+let is_record t =
+ op2bool (match_with_record t)
+
+
+(* 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
+ "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
+ | [_,None,c] -> c = mkRel (n - i)
+ | _ -> false) 0 lc
+
+let match_with_disjunction ?(strict=false) t =
+ let (hdapp,args) = decompose_app t in
+ match kind_of_term hdapp with
+ | Ind ind ->
+ let car = mis_constr_nargs ind in
+ let (mib,mip) = Global.lookup_inductive ind in
+ if array_for_all (fun ar -> ar = 1) car &&
+ not (mis_is_recursive (ind,mib,mip))
+ then
+ if strict then
+ if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then
+ Some (hdapp,args)
+ else
+ None
+ else
+ let cargs =
+ Array.map (fun ar -> pi2 (destProd (prod_applist ar args)))
+ mip.mind_nf_lc in
+ Some (hdapp,Array.to_list cargs)
+ else
+ None
+ | _ -> None
+
+let is_disjunction ?(strict=false) t =
+ op2bool (match_with_disjunction ~strict t)
-let is_disjunction t = op2bool (match_with_disjunction t)
+(* An empty type is an inductive type, possible with indices, that has no
+ constructors *)
let match_with_empty_type t =
let (hdapp,args) = decompose_app t in
@@ -113,22 +178,32 @@ let match_with_empty_type t =
let is_empty_type t = op2bool (match_with_empty_type t)
-let match_with_unit_type t =
+(* This filters inductive types with one constructor with no arguments;
+ Parameters and indices are allowed *)
+
+let match_with_unit_or_eq_type t =
let (hdapp,args) = decompose_app t in
match (kind_of_term hdapp) with
| Ind ind ->
let (mib,mip) = Global.lookup_inductive ind in
let 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 && array_for_all zero_args constr_types 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_type t = op2bool (match_with_unit_type t)
+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 *)
+
+let is_unit_type t =
+ match match_with_conjunction t with
+ | Some (_,t) when List.length t = 0 -> true
+ | _ -> false
(* Checks if a given term is an application of an
inductive binary relation R, so that R has only one constructor
@@ -157,6 +232,19 @@ let match_with_equation t =
let is_equation t = op2bool (match_with_equation t)
+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
+
let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ]
let match_arrow_pattern t =
@@ -186,15 +274,6 @@ let match_with_imp_term c=
let is_imp_term c = op2bool (match_with_imp_term c)
-let rec has_nodep_prod_after n c =
- match kind_of_term c with
- | 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
-
let match_with_nodep_ind t =
let (hdapp,args) = decompose_app t in
match (kind_of_term hdapp) with
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index 86cd191e..3c423202 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 8866 2006-05-28 16:21:04Z herbelin $ i*)
+(*i $Id: hipattern.mli 11739 2009-01-02 19:33:19Z herbelin $ i*)
(*i*)
open Util
@@ -52,23 +52,31 @@ type testing_function = constr -> bool
val match_with_non_recursive_type : (constr * constr list) matching_function
val is_non_recursive_type : testing_function
-val match_with_disjunction : (constr * constr list) matching_function
-val is_disjunction : testing_function
+val match_with_disjunction : ?strict:bool -> (constr * constr list) matching_function
+val is_disjunction : ?strict:bool -> testing_function
-val match_with_conjunction : (constr * constr list) matching_function
-val is_conjunction : testing_function
+val match_with_conjunction : ?strict:bool -> (constr * constr list) matching_function
+val is_conjunction : ?strict:bool -> testing_function
+
+val match_with_record : (constr * constr list) matching_function
+val is_record : testing_function
val match_with_empty_type : constr matching_function
val is_empty_type : testing_function
-val match_with_unit_type : constr matching_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
-(* type with only one constructor and no arguments *)
+(* 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
+(* type with only one constructor, no arguments and at least one dependency *)
+val match_with_equality_type : (constr * constr list) matching_function
+
val match_with_nottype : (constr * constr) matching_function
val is_nottype : testing_function
diff --git a/tactics/inv.ml b/tactics/inv.ml
index 68ebfd3c..977b602e 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: inv.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: inv.ml 11784 2009-01-14 11:36:32Z herbelin $ *)
open Pp
open Util
@@ -109,8 +109,8 @@ let make_inv_predicate env sigma indf realargs id status concl =
match dflt_concl with
| Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*)
| None ->
- let sort = get_sort_of env sigma concl in
- let p = make_arity env true indf sort in
+ let sort = get_sort_family_of env sigma concl in
+ let p = make_arity env true indf (new_sort_in_family sort) in
Unification.abstract_list_all env (Evd.create_evar_defs sigma)
p concl (realargs@[mkVar id]) in
let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in
@@ -469,7 +469,7 @@ let raw_inversion inv_kind id status names gl =
case_nodep_then_using
in
(tclTHENS
- (true_cut Anonymous cut_concl)
+ (assert_tac Anonymous cut_concl)
[case_tac names
(introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns))
(Some elim_predicate) ([],[]) ind indclause;
@@ -482,32 +482,14 @@ let raw_inversion inv_kind id status names gl =
gl
(* Error messages of the inversion tactics *)
-let not_found_message ids =
- if List.length ids = 1 then
- (str "the variable" ++ spc () ++ str (string_of_id (List.hd ids)) ++ spc () ++
- str" was not found in the current environment")
- else
- (str "the variables [" ++
- spc () ++ prlist (fun id -> (str (string_of_id id) ++ spc ())) ids ++
- str" ] were not found in the current environment")
-
-let dep_prop_prop_message id =
- errorlabstrm "Inv"
- (str "Inversion on " ++ pr_id id ++
- str " would need dependent elimination from Prop to Prop.")
-
-let not_inductive_here id =
- errorlabstrm "mind_specif_of_mind"
- (str "Cannot recognize an inductive predicate in " ++ pr_id id ++
- str ". If there is one, may be the structure of the arity or of the type of constructors is hidden by constant definitions.")
-
-(* Noms d'errreurs obsolètes ?? *)
let wrap_inv_error id = function
- | UserError ("Case analysis",s) -> errorlabstrm "Inv needs Nodep Prop Set" s
- | UserError("mind_specif_of_mind",_) -> not_inductive_here id
- | UserError (a,b) -> errorlabstrm "Inv" b
- | Invalid_argument "List.fold_left2" -> dep_prop_prop_message id
- | Not_found -> errorlabstrm "Inv" (not_found_message [id])
+ | Indrec.RecursionSchemeError
+ (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) ->
+ errorlabstrm ""
+ (strbrk "Inversion would require case analysis on sort " ++
+ pr_sort k ++
+ strbrk " which is not allowed for inductive definition " ++
+ pr_inductive (Global.env()) i ++ str ".")
| e -> raise e
(* The most general inversion tactic *)
diff --git a/tactics/refine.ml b/tactics/refine.ml
index 7ed58f6f..dff3b003 100644
--- a/tactics/refine.ml
+++ b/tactics/refine.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: refine.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: refine.ml 11671 2008-12-12 12:43:03Z herbelin $ *)
(* JCF -- 6 janvier 1998 EXPERIMENTAL *)
@@ -275,7 +275,7 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
| Lambda (Name id,_,m), _ ->
assert (isMeta (strip_outer_cast m));
begin match sgp with
- | [None] -> introduction id gl
+ | [None] -> intro_mustbe_force id gl
| [Some th] ->
tclTHEN (introduction id)
(onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)) gl
@@ -314,7 +314,7 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
because of evars limitation, use non dependent assert instead *)
| LetIn (Name id,c1,t1,c2), _ ->
tclTHENS
- (assert_tac true (Name id) t1)
+ (assert_tac (Name id) t1)
[(match List.hd sgp with
| None -> tclIDTAC
| Some th -> onLastHyp (fun id -> tcc_aux (mkVar id::subst) th));
diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml
deleted file mode 100644
index 95d56f11..00000000
--- a/tactics/setoid_replace.ml
+++ /dev/null
@@ -1,2023 +0,0 @@
-(************************************************************************)
-(* 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: setoid_replace.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
-
-open Tacmach
-open Proof_type
-open Libobject
-open Reductionops
-open Term
-open Termops
-open Names
-open Entries
-open Libnames
-open Nameops
-open Util
-open Pp
-open Printer
-open Environ
-open Clenv
-open Unification
-open Tactics
-open Tacticals
-open Vernacexpr
-open Safe_typing
-open Nametab
-open Decl_kinds
-open Constrintern
-open Mod_subst
-
-let replace = ref (fun _ _ _ -> assert false)
-let register_replace f = replace := f
-
-let general_rewrite = ref (fun _ _ -> assert false)
-let register_general_rewrite f = general_rewrite := f
-
-(* util function; it should be in util.mli *)
-let prlist_with_sepi sep elem =
- let rec aux n =
- function
- | [] -> mt ()
- | [h] -> elem n h
- | h::t ->
- let e = elem n h and s = sep() and r = aux (n+1) t in
- e ++ s ++ r
- in
- aux 1
-
-type relation =
- { rel_a: constr ;
- rel_aeq: constr;
- rel_refl: constr option;
- rel_sym: constr option;
- rel_trans : constr option;
- rel_quantifiers_no: int (* it helps unification *);
- rel_X_relation_class: constr;
- rel_Xreflexive_relation_class: constr
- }
-
-type 'a relation_class =
- Relation of 'a (* the rel_aeq of the relation or the relation *)
- | Leibniz of constr option (* the carrier (if eq is partially instantiated) *)
-
-type 'a morphism =
- { args : (bool option * 'a relation_class) list;
- output : 'a relation_class;
- lem : constr;
- morphism_theory : constr
- }
-
-type funct =
- { f_args : constr list;
- f_output : constr
- }
-
-type morphism_class =
- ACMorphism of relation morphism
- | ACFunction of funct
-
-let subst_mps_in_relation_class subst =
- function
- Relation t -> Relation (subst_mps subst t)
- | Leibniz t -> Leibniz (Option.map (subst_mps subst) t)
-
-let subst_mps_in_argument_class subst (variance,rel) =
- variance, subst_mps_in_relation_class subst rel
-
-let constr_relation_class_of_relation_relation_class =
- function
- Relation relation -> Relation relation.rel_aeq
- | Leibniz t -> Leibniz t
-
-
-let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
-
-let constant dir s = Coqlib.gen_constant "Setoid_replace" ("Setoids"::dir) s
-let gen_constant dir s = Coqlib.gen_constant "Setoid_replace" dir s
-let reference dir s = Coqlib.gen_reference "Setoid_replace" ("Setoids"::dir) s
-let eval_reference dir s = EvalConstRef (destConst (constant dir s))
-let eval_init_reference dir s = EvalConstRef (destConst (gen_constant ("Init"::dir) s))
-
-let current_constant id =
- try
- global_reference id
- with Not_found ->
- anomalylabstrm ""
- (str "Setoid: cannot find " ++ pr_id id ++
- str "(if loading Setoid.v under coqtop, use option \"-top Coq.Setoids.Setoid_tac\")")
-
-(* From Setoid.v *)
-
-let coq_reflexive =
- lazy(gen_constant ["Relations"; "Relation_Definitions"] "reflexive")
-let coq_symmetric =
- lazy(gen_constant ["Relations"; "Relation_Definitions"] "symmetric")
-let coq_transitive =
- lazy(gen_constant ["Relations"; "Relation_Definitions"] "transitive")
-let coq_relation =
- lazy(gen_constant ["Relations"; "Relation_Definitions"] "relation")
-
-let coq_Relation_Class = lazy(constant ["Setoid_tac"] "Relation_Class")
-let coq_Argument_Class = lazy(constant ["Setoid_tac"] "Argument_Class")
-let coq_Setoid_Theory = lazy(constant ["Setoid"] "Setoid_Theory")
-let coq_Morphism_Theory = lazy(constant ["Setoid_tac"] "Morphism_Theory")
-let coq_Build_Morphism_Theory= lazy(constant ["Setoid_tac"] "Build_Morphism_Theory")
-let coq_Compat = lazy(constant ["Setoid_tac"] "Compat")
-
-let coq_AsymmetricReflexive = lazy(constant ["Setoid_tac"] "AsymmetricReflexive")
-let coq_SymmetricReflexive = lazy(constant ["Setoid_tac"] "SymmetricReflexive")
-let coq_SymmetricAreflexive = lazy(constant ["Setoid_tac"] "SymmetricAreflexive")
-let coq_AsymmetricAreflexive = lazy(constant ["Setoid_tac"] "AsymmetricAreflexive")
-let coq_Leibniz = lazy(constant ["Setoid_tac"] "Leibniz")
-
-let coq_RAsymmetric = lazy(constant ["Setoid_tac"] "RAsymmetric")
-let coq_RSymmetric = lazy(constant ["Setoid_tac"] "RSymmetric")
-let coq_RLeibniz = lazy(constant ["Setoid_tac"] "RLeibniz")
-
-let coq_ASymmetric = lazy(constant ["Setoid_tac"] "ASymmetric")
-let coq_AAsymmetric = lazy(constant ["Setoid_tac"] "AAsymmetric")
-
-let coq_seq_refl = lazy(constant ["Setoid"] "Seq_refl")
-let coq_seq_sym = lazy(constant ["Setoid"] "Seq_sym")
-let coq_seq_trans = lazy(constant ["Setoid"] "Seq_trans")
-
-let coq_variance = lazy(constant ["Setoid_tac"] "variance")
-let coq_Covariant = lazy(constant ["Setoid_tac"] "Covariant")
-let coq_Contravariant = lazy(constant ["Setoid_tac"] "Contravariant")
-let coq_Left2Right = lazy(constant ["Setoid_tac"] "Left2Right")
-let coq_Right2Left = lazy(constant ["Setoid_tac"] "Right2Left")
-let coq_MSNone = lazy(constant ["Setoid_tac"] "MSNone")
-let coq_MSCovariant = lazy(constant ["Setoid_tac"] "MSCovariant")
-let coq_MSContravariant = lazy(constant ["Setoid_tac"] "MSContravariant")
-
-let coq_singl = lazy(constant ["Setoid_tac"] "singl")
-let coq_cons = lazy(constant ["Setoid_tac"] "necons")
-
-let coq_equality_morphism_of_asymmetric_areflexive_transitive_relation =
- lazy(constant ["Setoid_tac"]
- "equality_morphism_of_asymmetric_areflexive_transitive_relation")
-let coq_equality_morphism_of_symmetric_areflexive_transitive_relation =
- lazy(constant ["Setoid_tac"]
- "equality_morphism_of_symmetric_areflexive_transitive_relation")
-let coq_equality_morphism_of_asymmetric_reflexive_transitive_relation =
- lazy(constant ["Setoid_tac"]
- "equality_morphism_of_asymmetric_reflexive_transitive_relation")
-let coq_equality_morphism_of_symmetric_reflexive_transitive_relation =
- lazy(constant ["Setoid_tac"]
- "equality_morphism_of_symmetric_reflexive_transitive_relation")
-let coq_make_compatibility_goal =
- lazy(constant ["Setoid_tac"] "make_compatibility_goal")
-let coq_make_compatibility_goal_eval_ref =
- lazy(eval_reference ["Setoid_tac"] "make_compatibility_goal")
-let coq_make_compatibility_goal_aux_eval_ref =
- lazy(eval_reference ["Setoid_tac"] "make_compatibility_goal_aux")
-
-let coq_App = lazy(constant ["Setoid_tac"] "App")
-let coq_ToReplace = lazy(constant ["Setoid_tac"] "ToReplace")
-let coq_ToKeep = lazy(constant ["Setoid_tac"] "ToKeep")
-let coq_ProperElementToKeep = lazy(constant ["Setoid_tac"] "ProperElementToKeep")
-let coq_fcl_singl = lazy(constant ["Setoid_tac"] "fcl_singl")
-let coq_fcl_cons = lazy(constant ["Setoid_tac"] "fcl_cons")
-
-let coq_setoid_rewrite = lazy(constant ["Setoid_tac"] "setoid_rewrite")
-let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1")
-let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2")
-let coq_unit = lazy(gen_constant ["Init"; "Datatypes"] "unit")
-let coq_tt = lazy(gen_constant ["Init"; "Datatypes"] "tt")
-let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq")
-
-let coq_morphism_theory_of_function =
- lazy(constant ["Setoid_tac"] "morphism_theory_of_function")
-let coq_morphism_theory_of_predicate =
- lazy(constant ["Setoid_tac"] "morphism_theory_of_predicate")
-let coq_relation_of_relation_class =
- lazy(eval_reference ["Setoid_tac"] "relation_of_relation_class")
-let coq_directed_relation_of_relation_class =
- lazy(eval_reference ["Setoid_tac"] "directed_relation_of_relation_class")
-let coq_interp = lazy(eval_reference ["Setoid_tac"] "interp")
-let coq_Morphism_Context_rect2 =
- lazy(eval_reference ["Setoid_tac"] "Morphism_Context_rect2")
-let coq_iff = lazy(gen_constant ["Init";"Logic"] "iff")
-let coq_impl = lazy(constant ["Setoid_tac"] "impl")
-
-
-(************************* Table of declared relations **********************)
-
-
-(* Relations are stored in a table which is synchronised with the
- Reset mechanism. The table maps the term denoting the relation to
- the data of type relation that characterises the relation *)
-
-let relation_table = ref Gmap.empty
-
-let relation_table_add (s,th) = relation_table := Gmap.add s th !relation_table
-let relation_table_find s = Gmap.find s !relation_table
-let relation_table_mem s = Gmap.mem s !relation_table
-
-let prrelation s =
- str "(" ++ pr_lconstr s.rel_a ++ str "," ++ pr_lconstr s.rel_aeq ++ str ")"
-
-let prrelation_class =
- function
- Relation eq ->
- (try prrelation (relation_table_find eq)
- with Not_found ->
- str "[[ Error: " ++ pr_lconstr eq ++
- str " is not registered as a relation ]]")
- | Leibniz (Some ty) -> pr_lconstr ty
- | Leibniz None -> str "_"
-
-let prmorphism_argument_gen prrelation (variance,rel) =
- prrelation rel ++
- match variance with
- None -> str " ==> "
- | Some true -> str " ++> "
- | Some false -> str " --> "
-
-let prargument_class = prmorphism_argument_gen prrelation_class
-
-let pr_morphism_signature (l,c) =
- prlist (prmorphism_argument_gen Ppconstr.pr_constr_expr) l ++
- Ppconstr.pr_constr_expr c
-
-let prmorphism k m =
- pr_lconstr k ++ str ": " ++
- prlist prargument_class m.args ++
- prrelation_class m.output
-
-
-(* A function that gives back the only relation_class on a given carrier *)
-(*CSC: this implementation is really inefficient. I should define a new
- map to make it efficient. However, is this really worth of? *)
-let default_relation_for_carrier ?(filter=fun _ -> true) a =
- let rng = Gmap.rng !relation_table in
- match List.filter (fun ({rel_a=rel_a} as r) -> rel_a = a && filter r) rng with
- [] -> Leibniz (Some a)
- | relation::tl ->
- if tl <> [] then
- Flags.if_warn msg_warning
- (str "There are several relations on the carrier \"" ++
- pr_lconstr a ++ str "\". The relation " ++ prrelation relation ++
- str " is chosen.") ;
- Relation relation
-
-let find_relation_class rel =
- try Relation (relation_table_find rel)
- with
- Not_found ->
- let rel = Reduction.whd_betadeltaiota (Global.env ()) rel in
- match kind_of_term rel with
- | App (eq,[|ty|]) when eq_constr eq (Lazy.force coq_eq) -> Leibniz (Some ty)
- | _ when eq_constr rel (Lazy.force coq_eq) -> Leibniz None
- | _ -> raise Not_found
-
-let coq_iff_relation = lazy (find_relation_class (Lazy.force coq_iff))
-let coq_impl_relation = lazy (find_relation_class (Lazy.force coq_impl))
-
-let relation_morphism_of_constr_morphism =
- let relation_relation_class_of_constr_relation_class =
- function
- Leibniz t -> Leibniz t
- | Relation aeq ->
- Relation (try relation_table_find aeq with Not_found -> assert false)
- in
- function mor ->
- let args' =
- List.map
- (fun (variance,rel) ->
- variance, relation_relation_class_of_constr_relation_class rel
- ) mor.args in
- let output' = relation_relation_class_of_constr_relation_class mor.output in
- {mor with args=args' ; output=output'}
-
-let subst_relation subst relation =
- let rel_a' = subst_mps subst relation.rel_a in
- let rel_aeq' = subst_mps subst relation.rel_aeq in
- let rel_refl' = Option.map (subst_mps subst) relation.rel_refl in
- let rel_sym' = Option.map (subst_mps subst) relation.rel_sym in
- let rel_trans' = Option.map (subst_mps subst) relation.rel_trans in
- let rel_X_relation_class' = subst_mps subst relation.rel_X_relation_class in
- let rel_Xreflexive_relation_class' =
- subst_mps subst relation.rel_Xreflexive_relation_class
- in
- if rel_a' == relation.rel_a
- && rel_aeq' == relation.rel_aeq
- && rel_refl' == relation.rel_refl
- && rel_sym' == relation.rel_sym
- && rel_trans' == relation.rel_trans
- && rel_X_relation_class' == relation.rel_X_relation_class
- && rel_Xreflexive_relation_class'==relation.rel_Xreflexive_relation_class
- then
- relation
- else
- { rel_a = rel_a' ;
- rel_aeq = rel_aeq' ;
- rel_refl = rel_refl' ;
- rel_sym = rel_sym';
- rel_trans = rel_trans';
- rel_quantifiers_no = relation.rel_quantifiers_no;
- rel_X_relation_class = rel_X_relation_class';
- rel_Xreflexive_relation_class = rel_Xreflexive_relation_class'
- }
-
-let equiv_list () = List.map (fun x -> x.rel_aeq) (Gmap.rng !relation_table)
-
-let _ =
- Summary.declare_summary "relation-table"
- { Summary.freeze_function = (fun () -> !relation_table);
- Summary.unfreeze_function = (fun t -> relation_table := t);
- Summary.init_function = (fun () -> relation_table := Gmap .empty);
- Summary.survive_module = false;
- Summary.survive_section = false }
-
-(* Declare a new type of object in the environment : "relation-theory". *)
-
-let (relation_to_obj, obj_to_relation)=
- let cache_set (_,(s, th)) =
- let th' =
- if relation_table_mem s then
- begin
- let old_relation = relation_table_find s in
- let th' =
- {th with rel_sym =
- match th.rel_sym with
- None -> old_relation.rel_sym
- | Some t -> Some t} in
- Flags.if_warn msg_warning
- (strbrk "The relation " ++ prrelation th' ++
- strbrk " is redeclared. The new declaration" ++
- (match th'.rel_refl with
- None -> mt ()
- | Some t -> strbrk " (reflexivity proved by " ++ pr_lconstr t) ++
- (match th'.rel_sym with
- None -> mt ()
- | Some t ->
- (if th'.rel_refl = None then strbrk " (" else strbrk " and ")
- ++ strbrk "symmetry proved by " ++ pr_lconstr t) ++
- (if th'.rel_refl <> None && th'.rel_sym <> None then
- str ")" else str "") ++
- strbrk " replaces the old declaration" ++
- (match old_relation.rel_refl with
- None -> str ""
- | Some t -> strbrk " (reflexivity proved by " ++ pr_lconstr t) ++
- (match old_relation.rel_sym with
- None -> str ""
- | Some t ->
- (if old_relation.rel_refl = None then
- strbrk " (" else strbrk " and ") ++
- strbrk "symmetry proved by " ++ pr_lconstr t) ++
- (if old_relation.rel_refl <> None && old_relation.rel_sym <> None
- then str ")" else str "") ++
- str ".");
- th'
- end
- else
- th
- in
- relation_table_add (s,th')
- and subst_set (_,subst,(s,th as obj)) =
- let s' = subst_mps subst s in
- let th' = subst_relation subst th in
- if s' == s && th' == th then obj else
- (s',th')
- and export_set x = Some x
- in
- declare_object {(default_object "relation-theory") with
- cache_function = cache_set;
- load_function = (fun i o -> cache_set o);
- subst_function = subst_set;
- classify_function = (fun (_,x) -> Substitute x);
- export_function = export_set}
-
-(******************************* Table of declared morphisms ********************)
-
-(* Setoids are stored in a table which is synchronised with the Reset mechanism. *)
-
-let morphism_table = ref Gmap.empty
-
-let morphism_table_find m = Gmap.find m !morphism_table
-let morphism_table_add (m,c) =
- let old =
- try
- morphism_table_find m
- with
- Not_found -> []
- in
- try
- let old_morph =
- List.find
- (function mor -> mor.args = c.args && mor.output = c.output) old
- in
- Flags.if_warn msg_warning
- (strbrk "The morphism " ++ prmorphism m old_morph ++
- strbrk " is redeclared. " ++
- strbrk "The new declaration whose compatibility is proved by " ++
- pr_lconstr c.lem ++ strbrk " replaces the old declaration whose" ++
- strbrk " compatibility was proved by " ++
- pr_lconstr old_morph.lem ++ str ".")
- with
- Not_found -> morphism_table := Gmap.add m (c::old) !morphism_table
-
-let default_morphism ?(filter=fun _ -> true) m =
- match List.filter filter (morphism_table_find m) with
- [] -> raise Not_found
- | m1::ml ->
- if ml <> [] then
- Flags.if_warn msg_warning
- (strbrk "There are several morphisms associated to \"" ++
- pr_lconstr m ++ strbrk "\". Morphism " ++ prmorphism m m1 ++
- strbrk " is randomly chosen.");
- relation_morphism_of_constr_morphism m1
-
-let subst_morph subst morph =
- let lem' = subst_mps subst morph.lem in
- let args' = list_smartmap (subst_mps_in_argument_class subst) morph.args in
- let output' = subst_mps_in_relation_class subst morph.output in
- let morphism_theory' = subst_mps subst morph.morphism_theory in
- if lem' == morph.lem
- && args' == morph.args
- && output' == morph.output
- && morphism_theory' == morph.morphism_theory
- then
- morph
- else
- { args = args' ;
- output = output' ;
- lem = lem' ;
- morphism_theory = morphism_theory'
- }
-
-
-let _ =
- Summary.declare_summary "morphism-table"
- { Summary.freeze_function = (fun () -> !morphism_table);
- Summary.unfreeze_function = (fun t -> morphism_table := t);
- Summary.init_function = (fun () -> morphism_table := Gmap .empty);
- Summary.survive_module = false;
- Summary.survive_section = false }
-
-(* Declare a new type of object in the environment : "morphism-definition". *)
-
-let (morphism_to_obj, obj_to_morphism)=
- let cache_set (_,(m, c)) = morphism_table_add (m, c)
- and subst_set (_,subst,(m,c as obj)) =
- let m' = subst_mps subst m in
- let c' = subst_morph subst c in
- if m' == m && c' == c then obj else
- (m',c')
- and export_set x = Some x
- in
- declare_object {(default_object "morphism-definition") with
- cache_function = cache_set;
- load_function = (fun i o -> cache_set o);
- subst_function = subst_set;
- classify_function = (fun (_,x) -> Substitute x);
- export_function = export_set}
-
-(************************** Printing relations and morphisms **********************)
-
-let print_setoids () =
- Gmap.iter
- (fun k relation ->
- assert (k=relation.rel_aeq) ;
- ppnl (str"Relation " ++ prrelation relation ++ str";" ++
- (match relation.rel_refl with
- None -> str ""
- | Some t -> str" reflexivity proved by " ++ pr_lconstr t) ++
- (match relation.rel_sym with
- None -> str ""
- | Some t -> str " symmetry proved by " ++ pr_lconstr t) ++
- (match relation.rel_trans with
- None -> str ""
- | Some t -> str " transitivity proved by " ++ pr_lconstr t)))
- !relation_table ;
- Gmap.iter
- (fun k l ->
- List.iter
- (fun ({lem=lem} as mor) ->
- ppnl (str "Morphism " ++ prmorphism k mor ++
- str ". Compatibility proved by " ++
- pr_lconstr lem ++ str "."))
- l) !morphism_table
-;;
-
-(***************** Adding a morphism to the database ****************************)
-
-(* We maintain a table of the currently edited proofs of morphism lemma
- in order to add them in the morphism_table when the user does Save *)
-
-let edited = ref Gmap.empty
-
-let new_edited id m =
- edited := Gmap.add id m !edited
-
-let is_edited id =
- Gmap.mem id !edited
-
-let no_more_edited id =
- edited := Gmap.remove id !edited
-
-let what_edited id =
- Gmap.find id !edited
-
-(* also returns the triple (args_ty_quantifiers_rev,real_args_ty,real_output)
- where the args_ty and the output are delifted *)
-let check_is_dependent n args_ty output =
- let m = List.length args_ty - n in
- let args_ty_quantifiers, args_ty = Util.list_chop n args_ty in
- let rec aux m t =
- match kind_of_term t with
- Prod (n,s,t) when m > 0 ->
- if not (dependent (mkRel 1) t) then
- let args,out = aux (m - 1) (subst1 (mkRel 1) (* dummy *) t) in
- s::args,out
- else
- errorlabstrm "New Morphism"
- (str "The morphism is not a quantified non dependent product.")
- | _ -> [],t
- in
- let ty = compose_prod (List.rev args_ty) output in
- let args_ty, output = aux m ty in
- List.rev args_ty_quantifiers, args_ty, output
-
-let cic_relation_class_of_X_relation typ value =
- function
- {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} ->
- mkApp ((Lazy.force coq_AsymmetricReflexive),
- [| typ ; value ; rel_a ; rel_aeq; refl |])
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} ->
- mkApp ((Lazy.force coq_SymmetricReflexive),
- [| typ ; rel_a ; rel_aeq; sym ; refl |])
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} ->
- mkApp ((Lazy.force coq_AsymmetricAreflexive),
- [| typ ; value ; rel_a ; rel_aeq |])
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} ->
- mkApp ((Lazy.force coq_SymmetricAreflexive),
- [| typ ; rel_a ; rel_aeq; sym |])
-
-let cic_relation_class_of_X_relation_class typ value =
- function
- Relation {rel_X_relation_class=x_relation_class} ->
- mkApp (x_relation_class, [| typ ; value |])
- | Leibniz (Some t) ->
- mkApp ((Lazy.force coq_Leibniz), [| typ ; t |])
- | Leibniz None -> assert false
-
-
-let cic_precise_relation_class_of_relation =
- function
- {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} ->
- mkApp ((Lazy.force coq_RAsymmetric), [| rel_a ; rel_aeq; refl |])
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} ->
- mkApp ((Lazy.force coq_RSymmetric), [| rel_a ; rel_aeq; sym ; refl |])
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} ->
- mkApp ((Lazy.force coq_AAsymmetric), [| rel_a ; rel_aeq |])
- | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} ->
- mkApp ((Lazy.force coq_ASymmetric), [| rel_a ; rel_aeq; sym |])
-
-let cic_precise_relation_class_of_relation_class =
- function
- Relation
- {rel_aeq=rel_aeq; rel_Xreflexive_relation_class=lem; rel_refl=rel_refl }
- ->
- rel_aeq,lem,not(rel_refl=None)
- | Leibniz (Some t) ->
- mkApp ((Lazy.force coq_eq), [| t |]),
- mkApp ((Lazy.force coq_RLeibniz), [| t |]), true
- | Leibniz None -> assert false
-
-let cic_relation_class_of_relation_class rel =
- cic_relation_class_of_X_relation_class
- (Lazy.force coq_unit) (Lazy.force coq_tt) rel
-
-let cic_argument_class_of_argument_class (variance,arg) =
- let coq_variant_value =
- match variance with
- None -> (Lazy.force coq_Covariant) (* dummy value, it won't be used *)
- | Some true -> (Lazy.force coq_Covariant)
- | Some false -> (Lazy.force coq_Contravariant)
- in
- cic_relation_class_of_X_relation_class (Lazy.force coq_variance)
- coq_variant_value arg
-
-let cic_arguments_of_argument_class_list args =
- let rec aux =
- function
- [] -> assert false
- | [last] ->
- mkApp ((Lazy.force coq_singl), [| Lazy.force coq_Argument_Class; last |])
- | he::tl ->
- mkApp ((Lazy.force coq_cons),
- [| Lazy.force coq_Argument_Class; he ; aux tl |])
- in
- aux (List.map cic_argument_class_of_argument_class args)
-
-let gen_compat_lemma_statement quantifiers_rev output args m =
- let output = cic_relation_class_of_relation_class output in
- let args = cic_arguments_of_argument_class_list args in
- args, output,
- compose_prod quantifiers_rev
- (mkApp ((Lazy.force coq_make_compatibility_goal), [| args ; output ; m |]))
-
-let morphism_theory_id_of_morphism_proof_id id =
- id_of_string (string_of_id id ^ "_morphism_theory")
-
-(* apply_to_rels c [l1 ; ... ; ln] returns (c Rel1 ... reln) *)
-let apply_to_rels c l =
- if l = [] then c
- else
- let len = List.length l in
- applistc c (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 l)
-
-let apply_to_relation subst rel =
- if Array.length subst = 0 then rel
- else
- let new_quantifiers_no = rel.rel_quantifiers_no - Array.length subst in
- assert (new_quantifiers_no >= 0) ;
- { rel_a = mkApp (rel.rel_a, subst) ;
- rel_aeq = mkApp (rel.rel_aeq, subst) ;
- rel_refl = Option.map (fun c -> mkApp (c,subst)) rel.rel_refl ;
- rel_sym = Option.map (fun c -> mkApp (c,subst)) rel.rel_sym;
- rel_trans = Option.map (fun c -> mkApp (c,subst)) rel.rel_trans;
- rel_quantifiers_no = new_quantifiers_no;
- rel_X_relation_class = mkApp (rel.rel_X_relation_class, subst);
- rel_Xreflexive_relation_class =
- mkApp (rel.rel_Xreflexive_relation_class, subst) }
-
-let add_morphism lemma_infos mor_name (m,quantifiers_rev,args,output) =
- let lem =
- match lemma_infos with
- None ->
- (* the Morphism_Theory object has already been created *)
- let applied_args =
- let len = List.length quantifiers_rev in
- let subst =
- Array.of_list
- (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 quantifiers_rev)
- in
- List.map
- (fun (v,rel) ->
- match rel with
- Leibniz (Some t) ->
- assert (subst=[||]);
- v, Leibniz (Some t)
- | Leibniz None ->
- assert (Array.length subst = 1);
- v, Leibniz (Some (subst.(0)))
- | Relation rel -> v, Relation (apply_to_relation subst rel)) args
- in
- compose_lam quantifiers_rev
- (mkApp (Lazy.force coq_Compat,
- [| cic_arguments_of_argument_class_list applied_args;
- cic_relation_class_of_relation_class output;
- apply_to_rels (current_constant mor_name) quantifiers_rev |]))
- | Some (lem_name,argsconstr,outputconstr) ->
- (* only the compatibility has been proved; we need to declare the
- Morphism_Theory object *)
- let mext = current_constant lem_name in
- ignore (
- Declare.declare_internal_constant mor_name
- (DefinitionEntry
- {const_entry_body =
- compose_lam quantifiers_rev
- (mkApp ((Lazy.force coq_Build_Morphism_Theory),
- [| argsconstr; outputconstr; apply_to_rels m quantifiers_rev ;
- apply_to_rels mext quantifiers_rev |]));
- const_entry_type = None;
- const_entry_opaque = false;
- const_entry_boxed = Flags.boxed_definitions()},
- IsDefinition Definition)) ;
- mext
- in
- let mmor = current_constant mor_name in
- let args_constr =
- List.map
- (fun (variance,arg) ->
- variance, constr_relation_class_of_relation_relation_class arg) args in
- let output_constr = constr_relation_class_of_relation_relation_class output in
- Lib.add_anonymous_leaf
- (morphism_to_obj (m,
- { args = args_constr;
- output = output_constr;
- lem = lem;
- morphism_theory = mmor }));
- Flags.if_verbose ppnl (pr_lconstr m ++ str " is registered as a morphism")
-
-let error_cannot_unify_signature env k t t' =
- errorlabstrm "New Morphism"
- (str "One morphism argument or its output has type" ++ spc() ++
- pr_lconstr_env env t ++ strbrk " but the signature requires an argument" ++
- (if k = 0 then strbrk " of type " else
- strbrk "whose type is an instance of ") ++ pr_lconstr_env env t' ++
- str ".")
-
-(* first order matching with a bit of conversion *)
-let unify_relation_carrier_with_type env rel t =
- let args =
- match kind_of_term t with
- App (he',args') ->
- let argsno = Array.length args' - rel.rel_quantifiers_no in
- let args1 = Array.sub args' 0 argsno in
- let args2 = Array.sub args' argsno rel.rel_quantifiers_no in
- if is_conv env Evd.empty rel.rel_a (mkApp (he',args1)) then
- args2
- else
- error_cannot_unify_signature env rel.rel_quantifiers_no t rel.rel_a
- | _ ->
- try
- let args =
- Clenv.clenv_conv_leq env Evd.empty t rel.rel_a rel.rel_quantifiers_no
- in
- Array.of_list args
- with Reduction.NotConvertible ->
- error_cannot_unify_signature env rel.rel_quantifiers_no t rel.rel_a
- in
- apply_to_relation args rel
-
-let unify_relation_class_carrier_with_type env rel t =
- match rel with
- Leibniz (Some t') ->
- if is_conv env Evd.empty t t' then
- rel
- else
- error_cannot_unify_signature env 0 t t'
- | Leibniz None -> Leibniz (Some t)
- | Relation rel -> Relation (unify_relation_carrier_with_type env rel t)
-
-exception Impossible
-
-(* first order matching with a bit of conversion *)
-(* Note: the type checking operations performed by the function could *)
-(* be done once and for all abstracting the morphism structure using *)
-(* the quantifiers. Would the new structure be more suited than the *)
-(* existent one for other tasks to? (e.g. pretty printing would expose *)
-(* much more information: is it ok or is it too much information?) *)
-let unify_morphism_with_arguments gl (c,av)
- {args=args; output=output; lem=lem; morphism_theory=morphism_theory} t
-=
- let avlen = Array.length av in
- let argsno = List.length args in
- if avlen < argsno then raise Impossible; (* partial application *)
- let al = Array.to_list av in
- let quantifiers,al' = Util.list_chop (avlen - argsno) al in
- let quantifiersv = Array.of_list quantifiers in
- let c' = mkApp (c,quantifiersv) in
- if dependent t c' then raise Impossible;
- (* these are pf_type_of we could avoid *)
- let al'_type = List.map (Tacmach.pf_type_of gl) al' in
- let args' =
- List.map2
- (fun (var,rel) ty ->
- var,unify_relation_class_carrier_with_type (pf_env gl) rel ty)
- args al'_type in
- (* this is another pf_type_of we could avoid *)
- let ty = Tacmach.pf_type_of gl (mkApp (c,av)) in
- let output' = unify_relation_class_carrier_with_type (pf_env gl) output ty in
- let lem' = mkApp (lem,quantifiersv) in
- let morphism_theory' = mkApp (morphism_theory,quantifiersv) in
- ({args=args'; output=output'; lem=lem'; morphism_theory=morphism_theory'},
- c',Array.of_list al')
-
-let new_morphism m signature id hook =
- if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
- errorlabstrm "New Morphism" (pr_id id ++ str " already exists")
- else
- let env = Global.env() in
- let typeofm = Typing.type_of env Evd.empty m in
- let typ = clos_norm_flags Closure.betaiotazeta empty_env Evd.empty typeofm in
- let argsrev, output =
- match signature with
- None -> decompose_prod typ
- | Some (_,output') ->
- (* the carrier of the relation output' can be a Prod ==>
- we must uncurry on the fly output.
- E.g: A -> B -> C vs A -> (B -> C)
- args output args output
- *)
- let rel =
- try find_relation_class output'
- with Not_found -> errorlabstrm "Add Morphism"
- (str "Not a valid signature: " ++ pr_lconstr output' ++
- str " is neither a registered relation nor the Leibniz " ++
- str " equality.") in
- let rel_a,rel_quantifiers_no =
- match rel with
- Relation rel -> rel.rel_a, rel.rel_quantifiers_no
- | Leibniz (Some t) -> t, 0
- | Leibniz None -> let _,t = decompose_prod typ in t, 0 in
- let rel_a_n =
- clos_norm_flags Closure.betaiotazeta empty_env Evd.empty rel_a
- in
- try
- let _,output_rel_a_n = decompose_lam_n rel_quantifiers_no rel_a_n in
- let argsrev,_ = decompose_prod output_rel_a_n in
- let n = List.length argsrev in
- let argsrev',_ = decompose_prod typ in
- let m = List.length argsrev' in
- decompose_prod_n (m - n) typ
- with UserError(_,_) ->
- (* decompose_lam_n failed. This may happen when rel_a is an axiom,
- a constructor, an inductive type, etc. *)
- decompose_prod typ
- in
- let args_ty = List.rev argsrev in
- let args_ty_len = List.length (args_ty) in
- let args_ty_quantifiers_rev,args,args_instance,output,output_instance =
- match signature with
- None ->
- if args_ty = [] then
- errorlabstrm "New Morphism"
- (str "The term " ++ pr_lconstr m ++ str " has type " ++
- pr_lconstr typeofm ++ str " that is not a product.") ;
- ignore (check_is_dependent 0 args_ty output) ;
- let args =
- List.map
- (fun (_,ty) -> None,default_relation_for_carrier ty) args_ty in
- let output = default_relation_for_carrier output in
- [],args,args,output,output
- | Some (args,output') ->
- assert (args <> []);
- let number_of_arguments = List.length args in
- let number_of_quantifiers = args_ty_len - number_of_arguments in
- if number_of_quantifiers < 0 then
- errorlabstrm "New Morphism"
- (str "The morphism " ++ pr_lconstr m ++ str " has type " ++
- pr_lconstr typeofm ++ str " that expects at most " ++ int args_ty_len ++
- str " arguments. The signature that you specified requires " ++
- int number_of_arguments ++ str " arguments.")
- else
- begin
- (* the real_args_ty returned are already delifted *)
- let args_ty_quantifiers_rev, real_args_ty, real_output =
- check_is_dependent number_of_quantifiers args_ty output in
- let quantifiers_rel_context =
- List.map (fun (n,t) -> n,None,t) args_ty_quantifiers_rev in
- let env = push_rel_context quantifiers_rel_context env in
- let find_relation_class t real_t =
- try
- let rel = find_relation_class t in
- rel, unify_relation_class_carrier_with_type env rel real_t
- with Not_found ->
- errorlabstrm "Add Morphism"
- (str "Not a valid signature: " ++ pr_lconstr t ++
- str " is neither a registered relation nor the Leibniz " ++
- str " equality.")
- in
- let find_relation_class_v (variance,t) real_t =
- let relation,relation_instance = find_relation_class t real_t in
- match relation, variance with
- Leibniz _, None
- | Relation {rel_sym = Some _}, None
- | Relation {rel_sym = None}, Some _ ->
- (variance, relation), (variance, relation_instance)
- | Relation {rel_sym = None},None ->
- errorlabstrm "Add Morphism"
- (str "You must specify the variance in each argument " ++
- str "whose relation is asymmetric.")
- | Leibniz _, Some _
- | Relation {rel_sym = Some _}, Some _ ->
- errorlabstrm "Add Morphism"
- (str "You cannot specify the variance of an argument " ++
- str "whose relation is symmetric.")
- in
- let args, args_instance =
- List.split
- (List.map2 find_relation_class_v args real_args_ty) in
- let output,output_instance= find_relation_class output' real_output in
- args_ty_quantifiers_rev, args, args_instance, output, output_instance
- end
- in
- let argsconstr,outputconstr,lem =
- gen_compat_lemma_statement args_ty_quantifiers_rev output_instance
- args_instance (apply_to_rels m args_ty_quantifiers_rev) in
- (* "unfold make_compatibility_goal" *)
- let lem =
- Reductionops.clos_norm_flags
- (Closure.unfold_red (Lazy.force coq_make_compatibility_goal_eval_ref))
- env Evd.empty lem in
- (* "unfold make_compatibility_goal_aux" *)
- let lem =
- Reductionops.clos_norm_flags
- (Closure.unfold_red(Lazy.force coq_make_compatibility_goal_aux_eval_ref))
- env Evd.empty lem in
- (* "simpl" *)
- let lem = Tacred.simpl env Evd.empty lem in
- if Lib.is_modtype () then
- begin
- ignore
- (Declare.declare_internal_constant id
- (ParameterEntry (lem,false), IsAssumption Logical)) ;
- let mor_name = morphism_theory_id_of_morphism_proof_id id in
- let lemma_infos = Some (id,argsconstr,outputconstr) in
- add_morphism lemma_infos mor_name
- (m,args_ty_quantifiers_rev,args,output)
- end
- else
- begin
- new_edited id
- (m,args_ty_quantifiers_rev,args,argsconstr,output,outputconstr);
- Pfedit.start_proof id (Global, Proof Lemma)
- (Decls.clear_proofs (Global.named_context ()))
- lem hook;
- Flags.if_verbose msg (Printer.pr_open_subgoals ());
- end
-
-let morphism_hook _ ref =
- let pf_id = id_of_global ref in
- let mor_id = morphism_theory_id_of_morphism_proof_id pf_id in
- let (m,quantifiers_rev,args,argsconstr,output,outputconstr) =
- what_edited pf_id in
- if (is_edited pf_id)
- then
- begin
- add_morphism (Some (pf_id,argsconstr,outputconstr)) mor_id
- (m,quantifiers_rev,args,output) ;
- no_more_edited pf_id
- end
-
-type morphism_signature =
- (bool option * Topconstr.constr_expr) list * Topconstr.constr_expr
-
-let new_named_morphism id m sign =
- Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"];
- let sign =
- match sign with
- None -> None
- | Some (args,out) ->
- if args = [] then
- error "Morphism signature expects at least one argument.";
- Some
- (List.map (fun (variance,ty) -> variance, constr_of ty) args,
- constr_of out)
- in
- new_morphism (constr_of m) sign id morphism_hook
-
-(************************** Adding a relation to the database *********************)
-
-let check_a env a =
- let typ = Typing.type_of env Evd.empty a in
- let a_quantifiers_rev,_ = Reduction.dest_arity env typ in
- a_quantifiers_rev
-
-let check_eq env a_quantifiers_rev a aeq =
- let typ =
- Sign.it_mkProd_or_LetIn
- (mkApp ((Lazy.force coq_relation),[| apply_to_rels a a_quantifiers_rev |]))
- a_quantifiers_rev in
- if
- not
- (is_conv env Evd.empty (Typing.type_of env Evd.empty aeq) typ)
- then
- errorlabstrm "Add Relation Class"
- (pr_lconstr aeq ++ str " should have type (" ++ pr_lconstr typ ++ str ")")
-
-let check_property env a_quantifiers_rev a aeq strprop coq_prop t =
- if
- not
- (is_conv env Evd.empty (Typing.type_of env Evd.empty t)
- (Sign.it_mkProd_or_LetIn
- (mkApp ((Lazy.force coq_prop),
- [| apply_to_rels a a_quantifiers_rev ;
- apply_to_rels aeq a_quantifiers_rev |])) a_quantifiers_rev))
- then
- errorlabstrm "Add Relation Class"
- (str "Not a valid proof of " ++ str strprop ++ str ".")
-
-let check_refl env a_quantifiers_rev a aeq refl =
- check_property env a_quantifiers_rev a aeq "reflexivity" coq_reflexive refl
-
-let check_sym env a_quantifiers_rev a aeq sym =
- check_property env a_quantifiers_rev a aeq "symmetry" coq_symmetric sym
-
-let check_trans env a_quantifiers_rev a aeq trans =
- check_property env a_quantifiers_rev a aeq "transitivity" coq_transitive trans
-
-let check_setoid_theory env a_quantifiers_rev a aeq th =
- if
- not
- (is_conv env Evd.empty (Typing.type_of env Evd.empty th)
- (Sign.it_mkProd_or_LetIn
- (mkApp ((Lazy.force coq_Setoid_Theory),
- [| apply_to_rels a a_quantifiers_rev ;
- apply_to_rels aeq a_quantifiers_rev |])) a_quantifiers_rev))
- then
- errorlabstrm "Add Relation Class"
- (str "Not a valid proof of symmetry")
-
-let int_add_relation id a aeq refl sym trans =
- let env = Global.env () in
- let a_quantifiers_rev = check_a env a in
- check_eq env a_quantifiers_rev a aeq ;
- Option.iter (check_refl env a_quantifiers_rev a aeq) refl ;
- Option.iter (check_sym env a_quantifiers_rev a aeq) sym ;
- Option.iter (check_trans env a_quantifiers_rev a aeq) trans ;
- let quantifiers_no = List.length a_quantifiers_rev in
- let aeq_rel =
- { rel_a = a;
- rel_aeq = aeq;
- rel_refl = refl;
- rel_sym = sym;
- rel_trans = trans;
- rel_quantifiers_no = quantifiers_no;
- rel_X_relation_class = mkProp; (* dummy value, overwritten below *)
- rel_Xreflexive_relation_class = mkProp (* dummy value, overwritten below *)
- } in
- let x_relation_class =
- let subst =
- let len = List.length a_quantifiers_rev in
- Array.of_list
- (Util.list_map_i (fun i _ -> mkRel (len - i + 2)) 0 a_quantifiers_rev) in
- cic_relation_class_of_X_relation
- (mkRel 2) (mkRel 1) (apply_to_relation subst aeq_rel) in
- let _ =
- Declare.declare_internal_constant id
- (DefinitionEntry
- {const_entry_body =
- Sign.it_mkLambda_or_LetIn x_relation_class
- ([ Name (id_of_string "v"),None,mkRel 1;
- Name (id_of_string "X"),None,mkType (Termops.new_univ ())] @
- a_quantifiers_rev);
- const_entry_type = None;
- const_entry_opaque = false;
- const_entry_boxed = Flags.boxed_definitions()},
- IsDefinition Definition) in
- let id_precise = id_of_string (string_of_id id ^ "_precise_relation_class") in
- let xreflexive_relation_class =
- let subst =
- let len = List.length a_quantifiers_rev in
- Array.of_list
- (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 a_quantifiers_rev)
- in
- cic_precise_relation_class_of_relation (apply_to_relation subst aeq_rel) in
- let _ =
- Declare.declare_internal_constant id_precise
- (DefinitionEntry
- {const_entry_body =
- Sign.it_mkLambda_or_LetIn xreflexive_relation_class a_quantifiers_rev;
- const_entry_type = None;
- const_entry_opaque = false;
- const_entry_boxed = Flags.boxed_definitions() },
- IsDefinition Definition) in
- let aeq_rel =
- { aeq_rel with
- rel_X_relation_class = current_constant id;
- rel_Xreflexive_relation_class = current_constant id_precise } in
- Lib.add_anonymous_leaf (relation_to_obj (aeq, aeq_rel)) ;
- Flags.if_verbose ppnl (pr_lconstr aeq ++ str " is registered as a relation");
- match trans with
- None -> ()
- | Some trans ->
- let mor_name = id_of_string (string_of_id id ^ "_morphism") in
- let a_instance = apply_to_rels a a_quantifiers_rev in
- let aeq_instance = apply_to_rels aeq a_quantifiers_rev in
- let sym_instance =
- Option.map (fun x -> apply_to_rels x a_quantifiers_rev) sym in
- let refl_instance =
- Option.map (fun x -> apply_to_rels x a_quantifiers_rev) refl in
- let trans_instance = apply_to_rels trans a_quantifiers_rev in
- let aeq_rel_class_and_var1, aeq_rel_class_and_var2, lemma, output =
- match sym_instance, refl_instance with
- None, None ->
- (Some false, Relation aeq_rel),
- (Some true, Relation aeq_rel),
- mkApp
- ((Lazy.force
- coq_equality_morphism_of_asymmetric_areflexive_transitive_relation),
- [| a_instance ; aeq_instance ; trans_instance |]),
- Lazy.force coq_impl_relation
- | None, Some refl_instance ->
- (Some false, Relation aeq_rel),
- (Some true, Relation aeq_rel),
- mkApp
- ((Lazy.force
- coq_equality_morphism_of_asymmetric_reflexive_transitive_relation),
- [| a_instance ; aeq_instance ; refl_instance ; trans_instance |]),
- Lazy.force coq_impl_relation
- | Some sym_instance, None ->
- (None, Relation aeq_rel),
- (None, Relation aeq_rel),
- mkApp
- ((Lazy.force
- coq_equality_morphism_of_symmetric_areflexive_transitive_relation),
- [| a_instance ; aeq_instance ; sym_instance ; trans_instance |]),
- Lazy.force coq_iff_relation
- | Some sym_instance, Some refl_instance ->
- (None, Relation aeq_rel),
- (None, Relation aeq_rel),
- mkApp
- ((Lazy.force
- coq_equality_morphism_of_symmetric_reflexive_transitive_relation),
- [| a_instance ; aeq_instance ; refl_instance ; sym_instance ;
- trans_instance |]),
- Lazy.force coq_iff_relation in
- let _ =
- Declare.declare_internal_constant mor_name
- (DefinitionEntry
- {const_entry_body = Sign.it_mkLambda_or_LetIn lemma a_quantifiers_rev;
- const_entry_type = None;
- const_entry_opaque = false;
- const_entry_boxed = Flags.boxed_definitions()},
- IsDefinition Definition)
- in
- let a_quantifiers_rev =
- List.map (fun (n,b,t) -> assert (b = None); n,t) a_quantifiers_rev in
- add_morphism None mor_name
- (aeq,a_quantifiers_rev,[aeq_rel_class_and_var1; aeq_rel_class_and_var2],
- output)
-
-(* The vernac command "Add Relation ..." *)
-let add_relation id a aeq refl sym trans =
- Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"];
- int_add_relation id (constr_of a) (constr_of aeq) (Option.map constr_of refl)
- (Option.map constr_of sym) (Option.map constr_of trans)
-
-(************************ Add Setoid ******************************************)
-
-(* The vernac command "Add Setoid" *)
-let add_setoid id a aeq th =
- Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"];
- let a = constr_of a in
- let aeq = constr_of aeq in
- let th = constr_of th in
- let env = Global.env () in
- let a_quantifiers_rev = check_a env a in
- check_eq env a_quantifiers_rev a aeq ;
- check_setoid_theory env a_quantifiers_rev a aeq th ;
- let a_instance = apply_to_rels a a_quantifiers_rev in
- let aeq_instance = apply_to_rels aeq a_quantifiers_rev in
- let th_instance = apply_to_rels th a_quantifiers_rev in
- let refl =
- Sign.it_mkLambda_or_LetIn
- (mkApp ((Lazy.force coq_seq_refl),
- [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in
- let sym =
- Sign.it_mkLambda_or_LetIn
- (mkApp ((Lazy.force coq_seq_sym),
- [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in
- let trans =
- Sign.it_mkLambda_or_LetIn
- (mkApp ((Lazy.force coq_seq_trans),
- [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in
- int_add_relation id a aeq (Some refl) (Some sym) (Some trans)
-
-
-(****************************** The tactic itself *******************************)
-
-type direction =
- Left2Right
- | Right2Left
-
-let prdirection =
- function
- Left2Right -> str "->"
- | Right2Left -> str "<-"
-
-type constr_with_marks =
- | MApp of constr * morphism_class * constr_with_marks array * direction
- | ToReplace
- | ToKeep of constr * relation relation_class * direction
-
-let is_to_replace = function
- | ToKeep _ -> false
- | ToReplace -> true
- | MApp _ -> true
-
-let get_mark a =
- Array.fold_left (||) false (Array.map is_to_replace a)
-
-let cic_direction_of_direction =
- function
- Left2Right -> Lazy.force coq_Left2Right
- | Right2Left -> Lazy.force coq_Right2Left
-
-let opposite_direction =
- function
- Left2Right -> Right2Left
- | Right2Left -> Left2Right
-
-let direction_of_constr_with_marks hole_direction =
- function
- MApp (_,_,_,dir) -> cic_direction_of_direction dir
- | ToReplace -> hole_direction
- | ToKeep (_,_,dir) -> cic_direction_of_direction dir
-
-type argument =
- Toapply of constr (* apply the function to the argument *)
- | Toexpand of name * types (* beta-expand the function w.r.t. an argument
- of this type *)
-let beta_expand c args_rev =
- let rec to_expand =
- function
- [] -> []
- | (Toapply _)::tl -> to_expand tl
- | (Toexpand (name,s))::tl -> (name,s)::(to_expand tl) in
- let rec aux n =
- function
- [] -> []
- | (Toapply arg)::tl -> arg::(aux n tl)
- | (Toexpand _)::tl -> (mkRel n)::(aux (n + 1) tl)
- in
- compose_lam (to_expand args_rev)
- (mkApp (c, Array.of_list (List.rev (aux 1 args_rev))))
-
-exception Optimize (* used to fall-back on the tactic for Leibniz equality *)
-
-let relation_class_that_matches_a_constr caller_name new_goals hypt =
- let (heq, hargs) = decompose_app hypt in
- let rec get_all_but_last_two =
- function
- []
- | [_] ->
- errorlabstrm caller_name (pr_lconstr hypt ++
- str " is not a registered relation.")
- | [_;_] -> []
- | he::tl -> he::(get_all_but_last_two tl) in
- let all_aeq_args = get_all_but_last_two hargs in
- let rec find_relation l subst =
- let aeq = mkApp (heq,(Array.of_list l)) in
- try
- let rel = find_relation_class aeq in
- match rel,new_goals with
- Leibniz _,[] ->
- assert (subst = []);
- raise Optimize (* let's optimize the proof term size *)
- | Leibniz (Some _), _ ->
- assert (subst = []);
- rel
- | Leibniz None, _ ->
- (* for well-typedness reasons it should have been catched by the
- previous guard in the previous iteration. *)
- assert false
- | Relation rel,_ -> Relation (apply_to_relation (Array.of_list subst) rel)
- with Not_found ->
- if l = [] then
- errorlabstrm caller_name
- (pr_lconstr (mkApp (aeq, Array.of_list all_aeq_args)) ++
- str " is not a registered relation.")
- else
- let last,others = Util.list_sep_last l in
- find_relation others (last::subst)
- in
- find_relation all_aeq_args []
-
-(* rel1 is a subrelation of rel2 whenever
- forall x1 x2, rel1 x1 x2 -> rel2 x1 x2
- The Coq part of the tactic, however, needs rel1 == rel2.
- Hence the third case commented out.
- Note: accepting user-defined subrelations seems to be the last
- useful generalization that does not go against the original spirit of
- the tactic.
-*)
-let subrelation gl rel1 rel2 =
- match rel1,rel2 with
- Relation {rel_aeq=rel_aeq1}, Relation {rel_aeq=rel_aeq2} ->
- Tacmach.pf_conv_x gl rel_aeq1 rel_aeq2
- | Leibniz (Some t1), Leibniz (Some t2) ->
- Tacmach.pf_conv_x gl t1 t2
- | Leibniz None, _
- | _, Leibniz None -> assert false
-(* This is the commented out case (see comment above)
- | Leibniz (Some t1), Relation {rel_a=t2; rel_refl = Some _} ->
- Tacmach.pf_conv_x gl t1 t2
-*)
- | _,_ -> false
-
-(* this function returns the list of new goals opened by a constr_with_marks *)
-let rec collect_new_goals =
- function
- MApp (_,_,a,_) -> List.concat (List.map collect_new_goals (Array.to_list a))
- | ToReplace
- | ToKeep (_,Leibniz _,_)
- | ToKeep (_,Relation {rel_refl=Some _},_) -> []
- | ToKeep (c,Relation {rel_aeq=aeq; rel_refl=None},_) -> [mkApp(aeq,[|c ; c|])]
-
-(* two marked_constr are equivalent if they produce the same set of new goals *)
-let marked_constr_equiv_or_more_complex to_marked_constr gl c1 c2 =
- let glc1 = collect_new_goals (to_marked_constr c1) in
- let glc2 = collect_new_goals (to_marked_constr c2) in
- List.for_all (fun c -> List.exists (fun c' -> pf_conv_x gl c c') glc1) glc2
-
-let pr_new_goals i c =
- let glc = collect_new_goals c in
- str " " ++ int i ++ str ") side conditions:" ++
- (if glc = [] then str " no side conditions"
- else
- (pr_fnl () ++ str " " ++
- prlist_with_sep (fun () -> str "\n ")
- (fun c -> str " ... |- " ++ pr_lconstr c) glc))
-
-(* given a list of constr_with_marks, it returns the list where
- constr_with_marks than open more goals than simpler ones in the list
- are got rid of *)
-let elim_duplicates gl to_marked_constr =
- let rec aux =
- function
- [] -> []
- | he:: tl ->
- if List.exists
- (marked_constr_equiv_or_more_complex to_marked_constr gl he) tl
- then aux tl
- else he::aux tl
- in
- aux
-
-let filter_superset_of_new_goals gl new_goals l =
- List.filter
- (fun (_,_,c) ->
- List.for_all
- (fun g -> List.exists (pf_conv_x gl g) (collect_new_goals c)) new_goals) l
-
-(* given the array of lists [| l1 ; ... ; ln |] it returns the list of arrays
- [ c1 ; ... ; cn ] that is the cartesian product of the sets l1, ..., ln *)
-let cartesian_product gl a =
- let rec aux =
- function
- [] -> assert false
- | [he] -> List.map (fun e -> [e]) he
- | he::tl ->
- let tl' = aux tl in
- List.flatten
- (List.map (function e -> List.map (function l -> e :: l) tl') he)
- in
- List.map Array.of_list
- (aux (List.map (elim_duplicates gl identity) (Array.to_list a)))
-
-let mark_occur gl ~new_goals t in_c input_relation input_direction =
- let rec aux output_relation output_directions in_c =
- if eq_constr t in_c then
- if List.mem input_direction output_directions
- && subrelation gl input_relation output_relation then
- [ToReplace]
- else []
- else
- match kind_of_term in_c with
- | App (c,al) ->
- let mors_and_cs_and_als =
- let mors_and_cs_and_als =
- let morphism_table_find c =
- try morphism_table_find c with Not_found -> [] in
- let rec aux acc =
- function
- [] ->
- let c' = mkApp (c, Array.of_list acc) in
- let al' = [||] in
- List.map (fun m -> m,c',al') (morphism_table_find c')
- | (he::tl) as l ->
- let c' = mkApp (c, Array.of_list acc) in
- let al' = Array.of_list l in
- let acc' = acc @ [he] in
- (List.map (fun m -> m,c',al') (morphism_table_find c')) @
- (aux acc' tl)
- in
- aux [] (Array.to_list al) in
- let mors_and_cs_and_als =
- List.map
- (function (m,c,al) ->
- relation_morphism_of_constr_morphism m, c, al)
- mors_and_cs_and_als in
- let mors_and_cs_and_als =
- List.fold_left
- (fun l (m,c,al) ->
- try (unify_morphism_with_arguments gl (c,al) m t) :: l
- with Impossible -> l
- ) [] mors_and_cs_and_als
- in
- List.filter
- (fun (mor,_,_) -> subrelation gl mor.output output_relation)
- mors_and_cs_and_als
- in
- (* First we look for well typed morphisms *)
- let res_mors =
- List.fold_left
- (fun res (mor,c,al) ->
- let a =
- let arguments = Array.of_list mor.args in
- let apply_variance_to_direction =
- function
- None -> [Left2Right;Right2Left]
- | Some true -> output_directions
- | Some false -> List.map opposite_direction output_directions
- in
- Util.array_map2
- (fun a (variance,relation) ->
- (aux relation (apply_variance_to_direction variance) a)
- ) al arguments
- in
- let a' = cartesian_product gl a in
- List.flatten (List.map (fun output_direction ->
- (List.map
- (function a ->
- if not (get_mark a) then
- ToKeep (in_c,output_relation,output_direction)
- else
- MApp (c,ACMorphism mor,a,output_direction)) a'))
- output_directions) @ res
- ) [] mors_and_cs_and_als in
- (* Then we look for well typed functions *)
- let res_functions =
- (* the tactic works only if the function type is
- made of non-dependent products only. However, here we
- can cheat a bit by partially instantiating c to match
- the requirement when the arguments to be replaced are
- bound by non-dependent products only. *)
- let typeofc = Tacmach.pf_type_of gl c in
- let typ = nf_betaiota typeofc in
- let rec find_non_dependent_function env c c_args_rev typ f_args_rev
- a_rev
- =
- function
- [] ->
- if a_rev = [] then
- List.map (fun output_direction ->
- ToKeep (in_c,output_relation,output_direction))
- output_directions
- else
- let a' =
- cartesian_product gl (Array.of_list (List.rev a_rev))
- in
- List.fold_left
- (fun res a ->
- if not (get_mark a) then
- List.map (fun output_direction ->
- (ToKeep (in_c,output_relation,output_direction)))
- output_directions @ res
- else
- let err =
- match output_relation with
- Leibniz (Some typ') when pf_conv_x gl typ typ' ->
- false
- | Leibniz None -> assert false
- | _ when output_relation = Lazy.force coq_iff_relation
- -> false
- | _ -> true
- in
- if err then res
- else
- let mor =
- ACFunction{f_args=List.rev f_args_rev;f_output=typ} in
- let func = beta_expand c c_args_rev in
- List.map (fun output_direction ->
- (MApp (func,mor,a,output_direction)))
- output_directions @ res
- ) [] a'
- | (he::tl) ->
- let typnf = Reduction.whd_betadeltaiota env typ in
- match kind_of_term typnf with
- | Prod (name,s,t) ->
- let env' = push_rel (name,None,s) env in
- let he =
- (aux (Leibniz (Some s)) [Left2Right;Right2Left] he) in
- if he = [] then []
- else
- let he0 = List.hd he in
- begin
- match noccurn 1 t, he0 with
- _, ToKeep (arg,_,_) ->
- (* invariant: if he0 = ToKeep (t,_,_) then every
- element in he is = ToKeep (t,_,_) *)
- assert
- (List.for_all
- (function
- ToKeep(arg',_,_) when pf_conv_x gl arg arg' ->
- true
- | _ -> false) he) ;
- (* generic product, to keep *)
- find_non_dependent_function
- env' c ((Toapply arg)::c_args_rev)
- (subst1 arg t) f_args_rev a_rev tl
- | true, _ ->
- (* non-dependent product, to replace *)
- find_non_dependent_function
- env' c ((Toexpand (name,s))::c_args_rev)
- (lift 1 t) (s::f_args_rev) (he::a_rev) tl
- | false, _ ->
- (* dependent product, to replace *)
- (* This limitation is due to the reflexive
- implementation and it is hard to lift *)
- errorlabstrm "Setoid_replace"
- (str "Cannot rewrite in the argument of a " ++
- str "dependent product. If you need this " ++
- str "feature, please report to the author.")
- end
- | _ -> assert false
- in
- find_non_dependent_function (Tacmach.pf_env gl) c [] typ [] []
- (Array.to_list al)
- in
- elim_duplicates gl identity (res_functions @ res_mors)
- | Prod (_, c1, c2) ->
- if (dependent (mkRel 1) c2)
- then
- if (occur_term t c2)
- then errorlabstrm "Setoid_replace"
- (str "Cannot rewrite in the type of a variable bound " ++
- str "in a dependent product.")
- else
- List.map (fun output_direction ->
- ToKeep (in_c,output_relation,output_direction))
- output_directions
- else
- let typeofc1 = Tacmach.pf_type_of gl c1 in
- if not (Tacmach.pf_conv_x gl typeofc1 mkProp) then
- (* to avoid this error we should introduce an impl relation
- whose first argument is Type instead of Prop. However,
- the type of the new impl would be Type -> Prop -> Prop
- that is no longer a Relation_Definitions.relation. Thus
- the Coq part of the tactic should be heavily modified. *)
- errorlabstrm "Setoid_replace"
- (str "Rewriting in a product A -> B is possible only when A " ++
- str "is a proposition (i.e. A is of type Prop). The type " ++
- pr_lconstr c1 ++ str " has type " ++ pr_lconstr typeofc1 ++
- str " that is not convertible to Prop.")
- else
- aux output_relation output_directions
- (mkApp ((Lazy.force coq_impl),
- [| c1 ; subst1 (mkRel 1 (*dummy*)) c2 |]))
- | _ ->
- if occur_term t in_c then
- errorlabstrm "Setoid_replace"
- (str "Trying to replace " ++ pr_lconstr t ++ str " in " ++ pr_lconstr in_c ++
- str " that is not an applicative context.")
- else
- List.map (fun output_direction ->
- ToKeep (in_c,output_relation,output_direction))
- output_directions
- in
- let aux2 output_relation output_direction =
- List.map
- (fun res -> output_relation,output_direction,res)
- (aux output_relation [output_direction] in_c) in
- let res =
- (aux2 (Lazy.force coq_iff_relation) Right2Left) @
- (* [Left2Right] is the case of a prop of signature A ++> iff or B --> iff *)
- (aux2 (Lazy.force coq_iff_relation) Left2Right) @
- (aux2 (Lazy.force coq_impl_relation) Right2Left) in
- let res = elim_duplicates gl (function (_,_,t) -> t) res in
- let res' = filter_superset_of_new_goals gl new_goals res in
- match res' with
- [] when res = [] ->
- errorlabstrm "Setoid_rewrite"
- (strbrk "Either the term " ++ pr_lconstr t ++ strbrk " that must be " ++
- strbrk "rewritten occurs in a covariant position or the goal is not" ++
- strbrk " made of morphism applications only. You can replace only " ++
- strbrk "occurrences that are in a contravariant position and such " ++
- strbrk "that the context obtained by abstracting them is made of " ++
- strbrk "morphism applications only.")
- | [] ->
- errorlabstrm "Setoid_rewrite"
- (str "No generated set of side conditions is a superset of those " ++
- str "requested by the user. The generated sets of side conditions " ++
- str "are: " ++
- pr_fnl () ++
- prlist_with_sepi pr_fnl
- (fun i (_,_,mc) -> pr_new_goals i mc) res)
- | [he] -> he
- | he::_ ->
- Flags.if_warn msg_warning
- (strbrk "The application of the tactic is subject to one of " ++
- strbrk "the following set of side conditions that the user needs " ++
- strbrk "to prove:" ++
- pr_fnl () ++
- prlist_with_sepi pr_fnl
- (fun i (_,_,mc) -> pr_new_goals i mc) res' ++ pr_fnl () ++
- strbrk "The first set is randomly chosen. Use the syntax " ++
- strbrk "\"setoid_rewrite ... generate side conditions ...\" to choose " ++
- strbrk "a different set.") ;
- he
-
-let cic_morphism_context_list_of_list hole_relation hole_direction out_direction
-=
- let check =
- function
- (None,dir,dir') ->
- mkApp ((Lazy.force coq_MSNone), [| dir ; dir' |])
- | (Some true,dir,dir') ->
- assert (dir = dir');
- mkApp ((Lazy.force coq_MSCovariant), [| dir |])
- | (Some false,dir,dir') ->
- assert (dir <> dir');
- mkApp ((Lazy.force coq_MSContravariant), [| dir |]) in
- let rec aux =
- function
- [] -> assert false
- | [(variance,out),(value,direction)] ->
- mkApp ((Lazy.force coq_singl), [| Lazy.force coq_Argument_Class ; out |]),
- mkApp ((Lazy.force coq_fcl_singl),
- [| hole_relation; hole_direction ; out ;
- direction ; out_direction ;
- check (variance,direction,out_direction) ; value |])
- | ((variance,out),(value,direction))::tl ->
- let outtl, valuetl = aux tl in
- mkApp ((Lazy.force coq_cons),
- [| Lazy.force coq_Argument_Class ; out ; outtl |]),
- mkApp ((Lazy.force coq_fcl_cons),
- [| hole_relation ; hole_direction ; out ; outtl ;
- direction ; out_direction ;
- check (variance,direction,out_direction) ;
- value ; valuetl |])
- in aux
-
-let rec cic_type_nelist_of_list =
- function
- [] -> assert false
- | [value] ->
- mkApp ((Lazy.force coq_singl), [| mkType (Termops.new_univ ()) ; value |])
- | value::tl ->
- mkApp ((Lazy.force coq_cons),
- [| mkType (Termops.new_univ ()); value; cic_type_nelist_of_list tl |])
-
-let syntactic_but_representation_of_marked_but hole_relation hole_direction =
- let rec aux out (rel_out,precise_out,is_reflexive) =
- function
- MApp (f, m, args, direction) ->
- let direction = cic_direction_of_direction direction in
- let morphism_theory, relations =
- match m with
- ACMorphism { args = args ; morphism_theory = morphism_theory } ->
- morphism_theory,args
- | ACFunction { f_args = f_args ; f_output = f_output } ->
- let mt =
- if eq_constr out (cic_relation_class_of_relation_class
- (Lazy.force coq_iff_relation))
- then
- mkApp ((Lazy.force coq_morphism_theory_of_predicate),
- [| cic_type_nelist_of_list f_args; f|])
- else
- mkApp ((Lazy.force coq_morphism_theory_of_function),
- [| cic_type_nelist_of_list f_args; f_output; f|])
- in
- mt,List.map (fun x -> None,Leibniz (Some x)) f_args in
- let cic_relations =
- List.map
- (fun (variance,r) ->
- variance,
- r,
- cic_relation_class_of_relation_class r,
- cic_precise_relation_class_of_relation_class r
- ) relations in
- let cic_args_relations,argst =
- cic_morphism_context_list_of_list hole_relation hole_direction direction
- (List.map2
- (fun (variance,trel,t,precise_t) v ->
- (variance,cic_argument_class_of_argument_class (variance,trel)),
- (aux t precise_t v,
- direction_of_constr_with_marks hole_direction v)
- ) cic_relations (Array.to_list args))
- in
- mkApp ((Lazy.force coq_App),
- [|hole_relation ; hole_direction ;
- cic_args_relations ; out ; direction ;
- morphism_theory ; argst|])
- | ToReplace ->
- mkApp ((Lazy.force coq_ToReplace), [| hole_relation ; hole_direction |])
- | ToKeep (c,_,direction) ->
- let direction = cic_direction_of_direction direction in
- if is_reflexive then
- mkApp ((Lazy.force coq_ToKeep),
- [| hole_relation ; hole_direction ; precise_out ; direction ; c |])
- else
- let c_is_proper =
- let typ = mkApp (rel_out, [| c ; c |]) in
- mkCast (Evarutil.mk_new_meta (),DEFAULTcast, typ)
- in
- mkApp ((Lazy.force coq_ProperElementToKeep),
- [| hole_relation ; hole_direction; precise_out ;
- direction; c ; c_is_proper |])
- in aux
-
-let apply_coq_setoid_rewrite hole_relation prop_relation c1 c2 (direction,h)
- prop_direction m
-=
- let hole_relation = cic_relation_class_of_relation_class hole_relation in
- let hyp,hole_direction = h,cic_direction_of_direction direction in
- let cic_prop_relation = cic_relation_class_of_relation_class prop_relation in
- let precise_prop_relation =
- cic_precise_relation_class_of_relation_class prop_relation
- in
- mkApp ((Lazy.force coq_setoid_rewrite),
- [| hole_relation ; hole_direction ; cic_prop_relation ;
- prop_direction ; c1 ; c2 ;
- syntactic_but_representation_of_marked_but hole_relation hole_direction
- cic_prop_relation precise_prop_relation m ; hyp |])
-
-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
-
-(* For a correct meta-aware "rewrite in", we split unification
- apart from the actual rewriting (Pierre L, 05/04/06) *)
-
-(* [unification_rewrite] searchs a match for [c1] in [but] and then
- returns the modified objects (in particular [c1] and [c2]) *)
-
-let rewrite_unif_flags = {
- modulo_conv_on_closed_terms = None;
- use_metas_eagerly = true;
- modulo_delta = empty_transparent_state;
-}
-
-let rewrite2_unif_flags = {
- modulo_conv_on_closed_terms = Some full_transparent_state;
- use_metas_eagerly = true;
- modulo_delta = empty_transparent_state;
-}
-
-let unification_rewrite c1 c2 cl but gl =
- let (env',c1) =
- try
- (* ~flags:(false,true) to allow to mark occurences that must not be
- rewritten simply by replacing them with let-defined definitions
- in the context *)
- w_unify_to_subterm ~flags:rewrite_unif_flags (pf_env gl) (c1,but) cl.evd
- with
- Pretype_errors.PretypeError _ ->
- (* ~flags:(true,true) to make Ring work (since it really
- exploits conversion) *)
- w_unify_to_subterm ~flags:rewrite2_unif_flags
- (pf_env gl) (c1,but) cl.evd
- in
- let cl' = {cl with evd = env' } in
- let c2 = Clenv.clenv_nf_meta cl' c2 in
- check_evar_map_of_evars_defs env' ;
- env',Clenv.clenv_value cl', c1, c2
-
-(* no unification is performed in this function. [sigma] is the
- substitution obtained from an earlier unification. *)
-
-let relation_rewrite_no_unif c1 c2 hyp ~new_goals sigma gl =
- let but = pf_concl gl in
- try
- let input_relation =
- relation_class_that_matches_a_constr "Setoid_rewrite"
- new_goals (Typing.mtype_of (pf_env gl) sigma (snd hyp)) in
- let output_relation,output_direction,marked_but =
- mark_occur gl ~new_goals c1 but input_relation (fst hyp) in
- let cic_output_direction = cic_direction_of_direction output_direction in
- let if_output_relation_is_iff gl =
- let th =
- apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp
- cic_output_direction marked_but
- in
- let new_but = Termops.replace_term c1 c2 but in
- let hyp1,hyp2,proj =
- match output_direction with
- Right2Left -> new_but, but, Lazy.force coq_proj1
- | Left2Right -> but, new_but, Lazy.force coq_proj2
- in
- let impl1 = mkProd (Anonymous, hyp2, lift 1 hyp1) in
- let impl2 = mkProd (Anonymous, hyp1, lift 1 hyp2) in
- let th' = mkApp (proj, [|impl2; impl1; th|]) in
- Tactics.refine
- (mkApp (th',[|mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)|]))
- gl in
- let if_output_relation_is_if gl =
- let th =
- apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp
- cic_output_direction marked_but
- in
- let new_but = Termops.replace_term c1 c2 but in
- Tactics.refine
- (mkApp (th, [|mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)|]))
- gl in
- if output_relation = (Lazy.force coq_iff_relation) then
- if_output_relation_is_iff gl
- else
- if_output_relation_is_if gl
- with
- Optimize ->
- !general_rewrite (fst hyp = Left2Right) all_occurrences (snd hyp) gl
-
-let relation_rewrite c1 c2 (input_direction,cl) ~new_goals gl =
- let (sigma,cl,c1,c2) = unification_rewrite c1 c2 cl (pf_concl gl) gl in
- relation_rewrite_no_unif c1 c2 (input_direction,cl) ~new_goals sigma gl
-
-let analyse_hypothesis gl c =
- let ctype = pf_type_of gl c in
- let eqclause = Clenv.make_clenv_binding gl (c,ctype) Rawterm.NoBindings 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 equivalence" in
- let others,(c1,c2) = split_last_two args in
- eqclause,mkApp (equiv, Array.of_list others),c1,c2
-
-let general_s_rewrite lft2rgt occs c ~new_goals gl =
- if occs <> all_occurrences then
- warning "Rewriting at selected occurrences not supported";
- let eqclause,_,c1,c2 = analyse_hypothesis gl c in
- if lft2rgt then
- relation_rewrite c1 c2 (Left2Right,eqclause) ~new_goals gl
- else
- relation_rewrite c2 c1 (Right2Left,eqclause) ~new_goals gl
-
-let relation_rewrite_in id c1 c2 (direction,eqclause) ~new_goals gl =
- let hyp = pf_type_of gl (mkVar id) in
- (* first, we find a match for c1 in the hyp *)
- let (sigma,cl,c1,c2) = unification_rewrite c1 c2 eqclause hyp gl in
- (* since we will actually rewrite in the opposite direction, we also need
- to replace every occurrence of c2 (resp. c1) in hyp with something that
- is convertible but not syntactically equal. To this aim we introduce a
- let-in and then we will use the intro tactic to get rid of it.
- Quite tricky to do properly since c1 can occur in c2 or vice-versa ! *)
- let mangled_new_hyp =
- let hyp = lift 2 hyp in
- (* first, we backup every occurences of c1 in newly allocated (Rel 1) *)
- let hyp = Termops.replace_term (lift 2 c1) (mkRel 1) hyp in
- (* then, we factorize every occurences of c2 into (Rel 2) *)
- let hyp = Termops.replace_term (lift 2 c2) (mkRel 2) hyp in
- (* Now we substitute (Rel 1) (i.e. c1) for c2 *)
- let hyp = subst1 (lift 1 c2) hyp in
- (* Since subst1 has killed Rel 1 and decreased the other Rels,
- Rel 1 is now coding for c2, we can build the let-in factorizing c2 *)
- mkLetIn (Anonymous,c2,pf_type_of gl c2,hyp)
- in
- let new_hyp = Termops.replace_term c1 c2 hyp in
- let oppdir = opposite_direction direction in
- cut_replacing id new_hyp
- (tclTHENLAST
- (tclTHEN (change_in_concl None mangled_new_hyp)
- (tclTHEN intro
- (relation_rewrite_no_unif c2 c1 (oppdir,cl) ~new_goals sigma))))
- gl
-
-let general_s_rewrite_in id lft2rgt occs c ~new_goals gl =
- if occs <> all_occurrences then
- warning "Rewriting at selected occurrences not supported";
- let eqclause,_,c1,c2 = analyse_hypothesis gl c in
- if lft2rgt then
- relation_rewrite_in id c1 c2 (Left2Right,eqclause) ~new_goals gl
- else
- relation_rewrite_in id c2 c1 (Right2Left,eqclause) ~new_goals gl
-
-
-(*
- [general_setoid_replace rewrite_tac try_prove_eq_tac_opt relation c1 c2 ~new_goals ]
- common part of [setoid_replace] and [setoid_replace_in] (distinction is done using rewrite_tac).
-
- Algorith sketch:
- 1- find the (setoid) relation [rel] between [c1] and [c2] using [relation]
- 2- assert [H:rel c2 c1]
- 3- replace [c1] with [c2] using [rewrite_tac] (should be [general_s_rewrite] if we want to replace in the
- goal, and [general_s_rewrite_in id] if we want to replace in the hypothesis [id]). Possibly generate
- new_goals if asked (cf general_s_rewrite)
- 4- if [try_prove_eq_tac_opt] is [Some tac] try to complete [rel c2 c1] using tac and do nothing if
- [try_prove_eq_tac_opt] is [None]
-*)
-let general_setoid_replace rewrite_tac try_prove_eq_tac_opt relation c1 c2 ~new_goals gl =
- let try_prove_eq_tac =
- match try_prove_eq_tac_opt with
- | None -> Tacticals.tclIDTAC
- | Some tac -> Tacticals.tclTRY (Tacticals.tclCOMPLETE tac )
- in
- try
- let carrier,args = decompose_app (pf_type_of gl c1) in
- let relation =
- match relation with
- Some rel ->
- (try
- match find_relation_class rel with
- Relation sa -> if not (eq_constr carrier sa.rel_a) then
- errorlabstrm "Setoid_rewrite"
- (str "the carrier of " ++ pr_lconstr rel ++
- str " does not match the type of " ++ pr_lconstr c1);
- sa
- | Leibniz _ -> raise Optimize
- with
- Not_found ->
- errorlabstrm "Setoid_rewrite"
- (pr_lconstr rel ++ str " is not a registered relation."))
- | None ->
- match default_relation_for_carrier (pf_type_of gl c1) with
- Relation sa -> sa
- | Leibniz _ -> raise Optimize
- in
- let eq_left_to_right = mkApp (relation.rel_aeq, Array.of_list (List.append args [ c1 ; c2 ])) in
- let eq_right_to_left = mkApp (relation.rel_aeq, Array.of_list (List.append args [ c2 ; c1 ])) in
- let replace dir eq =
- tclTHENS (assert_tac false Anonymous eq)
- [onLastHyp (fun id ->
- tclTHEN
- (rewrite_tac dir all_occurrences (mkVar id) ~new_goals)
- (clear [id]));
- try_prove_eq_tac]
- in
- tclORELSE
- (replace true eq_left_to_right) (replace false eq_right_to_left) gl
- with
- Optimize -> (* (!replace tac_opt c1 c2) gl *)
- let eq = mkApp (Lazy.force coq_eq, [| pf_type_of gl c1;c2 ; c1 |]) in
- tclTHENS (assert_tac false Anonymous eq)
- [onLastHyp (fun id ->
- tclTHEN
- (rewrite_tac false all_occurrences (mkVar id) ~new_goals)
- (clear [id]));
- try_prove_eq_tac] gl
-
-let setoid_replace = general_setoid_replace general_s_rewrite
-let setoid_replace_in tac_opt id relation c1 c2 ~new_goals gl =
- general_setoid_replace (general_s_rewrite_in id) tac_opt relation c1 c2 ~new_goals gl
-
-(* [setoid_]{reflexivity,symmetry,transitivity} tactics *)
-
-let setoid_reflexivity gl =
- try
- let relation_class =
- relation_class_that_matches_a_constr "Setoid_reflexivity"
- [] (pf_concl gl) in
- match relation_class with
- Leibniz _ -> assert false (* since [] is empty *)
- | Relation rel ->
- match rel.rel_refl with
- None ->
- errorlabstrm "Setoid_reflexivity"
- (str "The relation " ++ prrelation rel ++ str " is not reflexive.")
- | Some refl -> apply refl gl
- with
- Optimize -> reflexivity_red true gl
-
-let setoid_symmetry gl =
- try
- let relation_class =
- relation_class_that_matches_a_constr "Setoid_symmetry"
- [] (pf_concl gl) in
- match relation_class with
- Leibniz _ -> assert false (* since [] is empty *)
- | Relation rel ->
- match rel.rel_sym with
- None ->
- errorlabstrm "Setoid_symmetry"
- (str "The relation " ++ prrelation rel ++ str " is not symmetric.")
- | Some sym -> apply sym gl
- with
- Optimize -> symmetry_red true gl
-
-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); assumption ] ]
- gl
-
-let setoid_transitivity c gl =
- try
- let relation_class =
- relation_class_that_matches_a_constr "Setoid_transitivity"
- [] (pf_concl gl) in
- match relation_class with
- Leibniz _ -> assert false (* since [] is empty *)
- | Relation rel ->
- let ctyp = pf_type_of gl c in
- let rel' = unify_relation_carrier_with_type (pf_env gl) rel ctyp in
- match rel'.rel_trans with
- None ->
- errorlabstrm "Setoid_transitivity"
- (str "The relation " ++ prrelation rel ++ str " is not transitive.")
- | Some trans ->
- let transty = nf_betaiota (pf_type_of gl trans) in
- let argsrev, _ =
- Reductionops.decomp_n_prod (pf_env gl) Evd.empty 2 transty in
- let binder =
- match List.rev argsrev with
- _::(Name n2,None,_)::_ -> Rawterm.NamedHyp n2
- | _ -> assert false
- in
- apply_with_bindings
- (trans, Rawterm.ExplicitBindings [ dummy_loc, binder, c ]) gl
- with
- Optimize -> transitivity_red true c gl
-;;
-
diff --git a/tactics/setoid_replace.mli b/tactics/setoid_replace.mli
deleted file mode 100644
index 6d736a0a..00000000
--- a/tactics/setoid_replace.mli
+++ /dev/null
@@ -1,85 +0,0 @@
-(************************************************************************)
-(* 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: setoid_replace.mli 11094 2008-06-10 19:35:23Z herbelin $ i*)
-
-open Term
-open Proof_type
-open Topconstr
-open Names
-open Termops
-
-type relation =
- { rel_a: constr ;
- rel_aeq: constr;
- rel_refl: constr option;
- rel_sym: constr option;
- rel_trans : constr option;
- rel_quantifiers_no: int (* it helps unification *);
- rel_X_relation_class: constr;
- rel_Xreflexive_relation_class: constr
- }
-
-type 'a relation_class =
- Relation of 'a (* the [rel_aeq] of the relation or the relation*)
- | Leibniz of constr option (* the [carrier] (if [eq] is partially instantiated)*)
-
-type 'a morphism =
- { args : (bool option * 'a relation_class) list;
- output : 'a relation_class;
- lem : constr;
- morphism_theory : constr
- }
-
-type morphism_signature = (bool option * constr_expr) list * constr_expr
-
-val pr_morphism_signature : morphism_signature -> Pp.std_ppcmds
-
-val register_replace : (tactic option -> constr -> constr -> tactic) -> unit
-val register_general_rewrite : (bool -> occurrences -> constr -> tactic) -> unit
-
-val print_setoids : unit -> unit
-
-val equiv_list : unit -> constr list
-val default_relation_for_carrier :
- ?filter:(relation -> bool) -> types -> relation relation_class
-(* [default_morphism] raises [Not_found] *)
-val default_morphism :
- ?filter:(constr morphism -> bool) -> constr -> relation morphism
-
-val setoid_replace :
- tactic option -> constr option -> constr -> constr -> new_goals:constr list -> tactic
-val setoid_replace_in :
- tactic option ->
- identifier -> constr option -> constr -> constr -> new_goals:constr list ->
- tactic
-
-val general_s_rewrite :
- bool -> occurrences -> constr -> new_goals:constr list -> tactic
-val general_s_rewrite_in :
- identifier -> bool -> occurrences -> constr -> new_goals:constr list -> tactic
-
-val setoid_reflexivity : tactic
-val setoid_symmetry : tactic
-val setoid_symmetry_in : identifier -> tactic
-val setoid_transitivity : constr -> tactic
-
-val add_relation :
- Names.identifier -> constr_expr -> constr_expr -> constr_expr option ->
- constr_expr option -> constr_expr option -> unit
-
-val add_setoid :
- Names.identifier -> constr_expr -> constr_expr -> constr_expr -> unit
-
-val new_named_morphism :
- Names.identifier -> constr_expr -> morphism_signature option -> unit
-
-val relation_table_find : constr -> relation
-val relation_table_mem : constr -> bool
-
-val prrelation : relation -> Pp.std_ppcmds
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index 3f8eb0ca..d9026a6d 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: tacinterp.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: tacinterp.ml 11745 2009-01-04 18:43:08Z herbelin $ *)
open Constrintern
open Closure
@@ -96,7 +96,7 @@ let catch_error call_trace tac g =
let (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
+ 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')))
@@ -135,9 +135,6 @@ let rec pr_value env = function
| VList (a::_) ->
str "a list (first element is " ++ pr_value env a ++ str")"
-(* Transforms a named_context into a (string * constr) list *)
-let make_hyps = List.map (fun (id,_,typ) -> (id, typ))
-
(* Transforms an id into a constr if possible, or fails *)
let constr_of_id env id =
construct_reference (Environ.named_context env) id
@@ -375,15 +372,15 @@ let intern_or_var ist = function
let loc_of_by_notation f = function
| AN c -> f c
- | ByNotation (loc,s) -> loc
+ | 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) ->
+ | ByNotation (loc,ntn,sc) ->
destIndRef (Notation.interp_notation_as_global_reference loc
- (function IndRef ind -> true | _ -> false) ntn)
+ (function IndRef ind -> true | _ -> false) ntn sc)
let intern_inductive ist = function
| AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id)
@@ -565,10 +562,10 @@ let interp_global_reference r =
let intern_evaluable_reference_or_by_notation = function
| AN r -> evaluable_of_global_reference (interp_global_reference r)
- | ByNotation (loc,ntn) ->
+ | ByNotation (loc,ntn,sc) ->
evaluable_of_global_reference
(Notation.interp_notation_as_global_reference loc
- (function ConstRef _ | VarRef _ -> true | _ -> false) ntn)
+ (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc)
(* Globalizes a reduction expression *)
let intern_evaluable ist = function
@@ -597,33 +594,34 @@ let intern_red_expr ist = function
| Simpl o -> Simpl (Option.map (intern_constr_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)
+
+let intern_hyp_list ist = List.map (intern_hyp_or_metaid ist)
let intern_inversion_strength lf ist = function
| NonDepInversion (k,idl,ids) ->
- NonDepInversion (k,List.map (intern_hyp_or_metaid ist) idl,
+ NonDepInversion (k,intern_hyp_list ist idl,
Option.map (intern_intro_pattern lf ist) ids)
| DepInversion (k,copt,ids) ->
DepInversion (k, Option.map (intern_constr ist) copt,
Option.map (intern_intro_pattern lf ist) ids)
| InversionUsing (c,idl) ->
- InversionUsing (intern_constr ist c, List.map (intern_hyp_or_metaid ist) idl)
+ InversionUsing (intern_constr ist c, intern_hyp_list ist idl)
(* Interprets an hypothesis name *)
let intern_hyp_location ist (((b,occs),id),hl) =
- (((b,List.map (intern_or_var ist) occs),intern_hyp ist (skip_metaid id)), hl)
-
-let interp_constrpattern_gen sigma env ?(as_type=false) ltacvar c =
- let c = intern_gen as_type ~allow_patvar:true ~ltacvars:(ltacvar,[])
- sigma env c in
- pattern_of_rawconstr c
+ (((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
- | Subterm (ido,pc) ->
- let (metas,pat) = interp_constrpattern_gen sigma env lfun pc in
- ido, metas, Subterm (ido,pat)
+ | 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)
| Term pc ->
- let (metas,pat) = interp_constrpattern_gen sigma env ~as_type lfun pc in
+ let ltacvars = (lfun,[]) in
+ let (metas,pat) = intern_constr_pattern sigma env ~as_type ~ltacvars pc in
None, metas, Term pat
let intern_constr_may_eval ist = function
@@ -658,6 +656,12 @@ let rec intern_match_goal_hyps sigma env lfun = function
let lfun, metas2, hyps = intern_match_goal_hyps sigma env 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 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 *)
@@ -690,8 +694,9 @@ let rec intern_atomic lf ist x =
| TacExact c -> TacExact (intern_constr ist c)
| TacExactNoCheck c -> TacExactNoCheck (intern_constr ist c)
| TacVmCastNoCheck c -> TacVmCastNoCheck (intern_constr ist c)
- | TacApply (a,ev,cb) ->
- TacApply (a,ev,List.map (intern_constr_with_bindings ist) cb)
+ | TacApply (a,ev,cb,inhyp) ->
+ TacApply (a,ev,List.map (intern_constr_with_bindings ist) cb,
+ Option.map (intern_in_hyp_as ist lf) inhyp)
| TacElim (ev,cb,cbo) ->
TacElim (ev,intern_constr_with_bindings ist cb,
Option.map (intern_constr_with_bindings ist) cbo)
@@ -709,7 +714,7 @@ let rec intern_atomic lf ist x =
| TacCut c -> TacCut (intern_type ist c)
| TacAssert (otac,ipat,c) ->
TacAssert (Option.map (intern_tactic ist) otac,
- intern_intro_pattern lf ist ipat,
+ Option.map (intern_intro_pattern lf ist) ipat,
intern_constr_gen (otac<>None) ist c)
| TacGeneralize cl ->
TacGeneralize (List.map (fun (c,na) ->
@@ -923,9 +928,10 @@ and intern_genarg ist x =
(* how to know which names are bound by the intropattern *)
in_gen globwit_intro_pattern
(intern_intro_pattern lf ist (out_gen rawwit_intro_pattern x))
- | IdentArgType ->
+ | IdentArgType b ->
let lf = ref ([],[]) in
- in_gen globwit_ident(intern_ident lf ist (out_gen rawwit_ident x))
+ 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))
| RefArgType ->
@@ -994,9 +1000,18 @@ let eval_pattern lfun c =
instantiate_pattern lvar c
let read_pattern lfun = function
- | Subterm (ido,pc) -> Subterm (ido,eval_pattern lfun pc)
+ | 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
@@ -1010,6 +1025,10 @@ let rec read_match_goal_hyps lfun lidh = function
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 *)
@@ -1029,45 +1048,79 @@ let is_match_catchable = function
| e -> Logic.catchable_exception e
(* Verifies if the matched list is coherent with respect to lcm *)
-let rec verify_metas_coherence gl lcm = function
+(* 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)::(verify_metas_coherence gl lcm tl)
+ (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,pat) (lhyps,nocc) =
+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 rec apply_one_mhyp_context_rec nocc = function
- | (id,hyp)::tl as hyps ->
- (match pat with
- | Term t ->
- (try
- let lmeta = verify_metas_coherence gl lmatch (matches t hyp) in
- (get_id_couple id hypname,lmeta,(id,hyp),(tl,0))
- with
- | PatternMatchingFailure | Not_coherent_metas ->
- apply_one_mhyp_context_rec 0 tl)
- | Subterm (ic,t) ->
+ let match_pat lmatch hyp pat =
+ match pat with
+ | Term t ->
+ let lmeta = extended_matches t hyp in
(try
- let (lm,ctxt) = match_subterm nocc t hyp in
- let lmeta = verify_metas_coherence gl lmatch lm in
- ((get_id_couple id hypname)@(give_context ctxt ic),
- lmeta,(id,hyp),(hyps,nocc + 1))
- with
- | PatternMatchingFailure ->
- apply_one_mhyp_context_rec 0 tl
- | Not_coherent_metas ->
- apply_one_mhyp_context_rec (nocc + 1) hyps))
+ 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 () -> 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 () -> 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 nocc lhyps
+ in
+ apply_one_mhyp_context_rec lhyps
let constr_to_id loc = function
| VConstr c when isVar c -> destVar c
@@ -1361,7 +1414,7 @@ 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 ->
delete_current_proof();
@@ -1385,7 +1438,7 @@ let solve_remaining_evars env initial_sigma evd c =
Pretype_errors.error_unsolvable_implicit loc env sigma evi src None)
| _ -> map_constr proc_rec c
in
- proc_rec c
+ proc_rec (Evarutil.nf_isevar !evdref c)
let interp_gen kind ist sigma env (c,ce) =
let (ltacvars,unbndltacvars as vars) = constr_list ist env in
@@ -1413,6 +1466,10 @@ 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_open_type ccl ist sigma env cc =
+ let evd,c = interp_gen IsType ist sigma env cc in
+ (evars_of evd,c)
+
let interp_constr = interp_econstr (OfType None)
let interp_type = interp_econstr IsType
@@ -1600,6 +1657,9 @@ let rec interp_intro_pattern ist gl = function
and interp_or_and_intro_pattern ist gl =
List.map (List.map (interp_intro_pattern ist gl))
+let interp_in_hyp_as ist gl (id,ipat) =
+ (interp_hyp ist gl id,Option.map (interp_intro_pattern ist gl) ipat)
+
(* Quantified named or numbered hypothesis or hypothesis in context *)
(* (as in Inversion) *)
let coerce_to_quantified_hypothesis = function
@@ -1840,13 +1900,18 @@ and interp_letin ist gl llc u =
val_interp ist gl u
(* Interprets the Match Context expressions *)
-and interp_match_goal ist g lz lr lmr =
- let rec apply_goal_sub ist env goal nocc (id,c) csr mt mhyps hyps =
- let (lgoal,ctxt) = match_subterm nocc c csr in
- let lctxt = give_context ctxt id in
+and interp_match_goal ist goal lz lr lmr =
+ let hyps = pf_hyps goal in
+ let hyps = if lr then List.rev hyps else hyps in
+ let concl = pf_concl goal in
+ let env = pf_env goal in
+ let rec apply_goal_sub app ist (id,c) csr mt mhyps hyps =
+ 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
- with e when is_match_catchable e ->
- apply_goal_sub ist env goal (nocc + 1) (id,c) csr mt mhyps hyps in
+ 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 =
begin
if lex<>[] then db_pattern_rule ist.debug nrs (List.hd lex);
@@ -1859,27 +1924,24 @@ and interp_match_goal ist g lz lr lmr =
apply_match_goal ist env goal (nrs+1) (List.tl lex) tl
end
| (Pat (mhyps,mgoal,mt))::tl ->
- let hyps = make_hyps (pf_hyps goal) in
- let hyps = if lr then List.rev hyps else hyps in
- let mhyps = List.rev mhyps (* Sens naturel *) in
- let concl = pf_concl goal in
- (match mgoal with
- | Term mg ->
- (try
- let lgoal = matches mg concl in
- db_matched_concl ist.debug (pf_env goal) concl;
- apply_hyps_context ist env lz goal mt [] lgoal mhyps hyps
- with e when is_match_catchable e ->
- (match e with
- | PatternMatchingFailure -> db_matching_failure ist.debug
- | Eval_fail s -> db_eval_failure ist.debug s
- | _ -> db_logic_failure ist.debug e);
- apply_match_goal ist env goal (nrs+1) (List.tl lex) tl)
- | Subterm (id,mg) ->
- (try apply_goal_sub ist env goal 0 (id,mg) concl mt mhyps hyps
- with
- | PatternMatchingFailure ->
- apply_match_goal ist env goal (nrs+1) (List.tl lex) tl))
+ let mhyps = List.rev mhyps (* Sens naturel *) in
+ (match mgoal with
+ | Term mg ->
+ (try
+ let lmatch = extended_matches mg concl in
+ db_matched_concl ist.debug env concl;
+ apply_hyps_context ist env lz goal mt [] lmatch mhyps hyps
+ with e when is_match_catchable e ->
+ (match e with
+ | PatternMatchingFailure -> db_matching_failure ist.debug
+ | Eval_fail s -> db_eval_failure ist.debug s
+ | _ -> db_logic_failure ist.debug e);
+ apply_match_goal ist env goal (nrs+1) (List.tl lex) tl)
+ | Subterm (b,id,mg) ->
+ (try apply_goal_sub b ist (id,mg) concl mt mhyps hyps
+ with
+ | PatternMatchingFailure ->
+ apply_match_goal ist env goal (nrs+1) (List.tl lex) tl))
| _ ->
errorlabstrm "Tacinterp.apply_match_goal"
(v 0 (str "No matching clauses for match goal" ++
@@ -1887,31 +1949,36 @@ and interp_match_goal ist g lz lr lmr =
fnl() ++ str "(use \"Set Ltac Debug\" for more info)"
else mt()) ++ str"."))
end in
- let env = pf_env g in
- apply_match_goal ist env g 0 lmr
+ apply_match_goal ist env goal 0 lmr
(read_match_rule (fst (constr_list ist env)) lmr)
(* Tries to match the hypotheses in a Match Context *)
and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps =
- let rec apply_hyps_context_rec lfun lmatch lhyps_rest current = function
- | Hyp ((_,hypname),mhyp)::tl as mhyps ->
- let (lids,lm,hyp_match,next) =
- apply_one_mhyp_context ist env goal lmatch (hypname,mhyp) current in
- db_matched_hyp ist.debug (pf_env goal) hyp_match hypname;
- begin
+ let rec apply_hyps_context_rec lfun lmatch lhyps_rest = function
+ | hyp_pat::tl ->
+ let (hypname, _, _ as hyp_pat) =
+ match hyp_pat with
+ | Hyp ((_,hypname),mhyp) -> hypname, None, mhyp
+ | Def ((_,hypname),mbod,mhyp) -> hypname, Some mbod, mhyp
+ in
+ let rec match_next_pattern find_next =
+ let (lids,lm,hyp_match,find_next') = find_next () in
+ db_matched_hyp ist.debug (pf_env goal) hyp_match hypname;
try
- let nextlhyps = list_except hyp_match lhyps_rest in
- apply_hyps_context_rec (lfun@lids) (lmatch@lm) nextlhyps
- (nextlhyps,0) tl
+ 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 ->
- apply_hyps_context_rec lfun lmatch lhyps_rest next mhyps
- end
+ match_next_pattern find_next' in
+ let init_match_pattern () =
+ apply_one_mhyp_context ist env goal lmatch hyp_pat lhyps_rest in
+ match_next_pattern init_match_pattern
| [] ->
- let lmatch = List.map (fun (id,c) -> (id,VConstr c)) lmatch in
+ let lfun = extend_values_with_bindings lmatch (lfun@ist.lfun) in
db_mc_pattern_success ist.debug;
- eval_with_fail {ist with lfun=lmatch@lfun@ist.lfun} lz goal mt
+ eval_with_fail {ist with lfun=lfun} lz goal mt
in
- apply_hyps_context_rec lctxt lgmatch hyps (hyps,0) mhyps
+ apply_hyps_context_rec lctxt lgmatch hyps mhyps
and interp_external loc ist gl com req la =
let f ch = extern_request ch req gl la in
@@ -1933,9 +2000,9 @@ and interp_genarg ist gl x =
| IntroPatternArgType ->
in_gen wit_intro_pattern
(interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
- | IdentArgType ->
- in_gen wit_ident
- (interp_fresh_ident ist gl (out_gen globwit_ident x))
+ | IdentArgType b ->
+ in_gen (wit_ident_gen b)
+ (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 ->
@@ -2003,30 +2070,31 @@ and interp_genarg_var_list1 ist gl x =
(* Interprets the Match expressions *)
and interp_match ist g lz constr lmr =
- let rec apply_match_subterm ist nocc (id,c) csr mt =
- let (lm,ctxt) = match_subterm nocc c csr in
- let lctxt = give_context ctxt id in
- let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in
- try eval_with_fail {ist with lfun=lm@lctxt@ist.lfun} lz g mt
- with e when is_match_catchable e ->
- apply_match_subterm ist (nocc + 1) (id,c) csr mt
- in
+ let rec apply_match_subterm app ist (id,c) csr mt =
+ 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
+ try eval_with_fail {ist with lfun=lfun} lz g mt
+ 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 ist csr = function
| (All t)::_ ->
(try eval_with_fail ist lz g t
with e when is_match_catchable e -> apply_match ist csr [])
| (Pat ([],Term c,mt))::tl ->
(try
- let lm =
- try matches c csr
+ let lmatch =
+ try extended_matches c csr
with e ->
debugging_exception_step ist false e (fun () ->
str "matching with pattern" ++ fnl () ++
pr_constr_pattern_env (pf_env g) c);
raise e in
try
- let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in
- eval_with_fail { ist with lfun=lm@ist.lfun } lz g mt
+ let lfun = extend_values_with_bindings lmatch ist.lfun in
+ eval_with_fail { ist with lfun=lfun } lz g mt
with e ->
debugging_exception_step ist false e (fun () ->
str "rule body for pattern" ++
@@ -2036,8 +2104,8 @@ and interp_match ist g lz constr lmr =
debugging_step ist (fun () -> str "switching to the next rule");
apply_match ist csr tl)
- | (Pat ([],Subterm (id,c),mt))::tl ->
- (try apply_match_subterm ist 0 (id,c) csr mt
+ | (Pat ([],Subterm (b,id,c),mt))::tl ->
+ (try apply_match_subterm b ist (id,c) csr mt
with PatternMatchingFailure -> apply_match ist csr tl)
| _ ->
errorlabstrm "Tacinterp.apply_match" (str
@@ -2119,8 +2187,11 @@ and interp_atomic ist gl = function
| 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) ->
- h_apply a ev (List.map (interp_constr_with_bindings ist gl) cb)
+ | 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)
| TacElim (ev,cb,cbo) ->
h_elim ev (interp_constr_with_bindings ist gl cb)
(Option.map (interp_constr_with_bindings ist gl) cbo)
@@ -2137,10 +2208,10 @@ and interp_atomic ist gl = function
h_mutual_cofix b (interp_fresh_ident ist gl 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 pf_interp_constr else pf_interp_type) ist gl c in
+ 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))
(Tactics.forward (Option.map (interp_tactic ist) t)
- (interp_intro_pattern ist gl ipat) c)
+ (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)
@@ -2230,7 +2301,7 @@ and interp_atomic ist gl = function
(* Equality and inversion *)
| TacRewrite (ev,l,cl,by) ->
Equality.general_multi_multi_rewrite ev
- (List.map (fun (b,m,c) -> (b,m,interp_constr_with_bindings ist gl c)) l)
+ (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)
| TacInversion (DepInversion (k,c,ids),hyp) ->
@@ -2263,10 +2334,10 @@ and interp_atomic ist gl = function
| IntroPatternArgType ->
VIntroPattern
(snd (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)))
- | IdentArgType ->
+ | IdentArgType b ->
VIntroPattern
(IntroIdentifier
- (interp_fresh_ident ist gl (out_gen globwit_ident x)))
+ (interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x)))
| VarArgType ->
mk_hyp_value ist gl (out_gen globwit_var x)
| RefArgType ->
@@ -2437,13 +2508,16 @@ let subst_raw_may_eval subst = function
| ConstrTerm c -> ConstrTerm (subst_rawconstr subst c)
let subst_match_pattern subst = function
- | Subterm (ido,pc) -> Subterm (ido,subst_pattern subst pc)
+ | Subterm (b,ido,pc) -> Subterm (b,ido,subst_pattern subst pc)
| Term pc -> Term (subst_pattern subst pc)
let rec subst_match_goal_hyps subst = function
| Hyp (locs,mp) :: tl ->
Hyp (locs,subst_match_pattern subst mp)
:: subst_match_goal_hyps subst tl
+ | Def (locs,mv,mp) :: tl ->
+ Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp)
+ :: subst_match_goal_hyps subst tl
| [] -> []
let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
@@ -2453,8 +2527,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
| TacExact c -> TacExact (subst_rawconstr subst c)
| TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c)
| TacVmCastNoCheck c -> TacVmCastNoCheck (subst_rawconstr subst c)
- | TacApply (a,ev,cb) ->
- TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb)
+ | TacApply (a,ev,cb,cl) ->
+ TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb,cl)
| TacElim (ev,cb,cbo) ->
TacElim (ev,subst_raw_with_bindings subst cb,
Option.map (subst_raw_with_bindings subst) cbo)
@@ -2611,7 +2685,8 @@ 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 -> in_gen globwit_ident (out_gen globwit_ident x)
+ | 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
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
index 928e5914..add57cb5 100644
--- a/tactics/tacinterp.mli
+++ b/tactics/tacinterp.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: tacinterp.mli 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id: tacinterp.mli 11576 2008-11-10 19:13:15Z msozeau $ i*)
(*i*)
open Dyn
@@ -48,6 +48,9 @@ and interp_sign =
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
@@ -99,6 +102,10 @@ val intern_tactic :
val intern_constr :
glob_sign -> constr_expr -> rawconstr_and_expr
+val intern_constr_with_bindings :
+ glob_sign -> constr_expr * constr_expr Rawterm.bindings ->
+ rawconstr_and_expr * rawconstr_and_expr Rawterm.bindings
+
val intern_hyp :
glob_sign -> identifier Util.located -> identifier Util.located
@@ -124,6 +131,9 @@ 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
+
(* Initial call for interpretation *)
val glob_tactic : raw_tactic_expr -> glob_tactic_expr
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index 3b13d1a0..28e987fa 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: tacticals.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: tacticals.ml 11735 2009-01-02 17:22:31Z herbelin $ *)
open Pp
open Util
@@ -41,6 +41,7 @@ open Tacexpr
let tclNORMEVAR = tclNORMEVAR
let tclIDTAC = tclIDTAC
let tclIDTAC_MESSAGE = tclIDTAC_MESSAGE
+let tclORELSE0 = tclORELSE0
let tclORELSE = tclORELSE
let tclTHEN = tclTHEN
let tclTHENLIST = tclTHENLIST
@@ -75,7 +76,7 @@ let tclIFTHENTRYELSEMUST = tclIFTHENTRYELSEMUST
let unTAC = unTAC
(* [rclTHENSEQ [t1;..;tn] is equivalent to t1;..;tn *)
-let tclTHENSEQ = List.fold_left tclTHEN tclIDTAC
+let tclTHENSEQ = tclTHENLIST
(* map_tactical f [x1..xn] = (f x1);(f x2);...(f xn) *)
(* tclMAP f [x1..xn] = (f x1);(f x2);...(f xn) *)
@@ -88,10 +89,16 @@ 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 tclNTH_DECL m tac gl =
+ tac (try List.nth (pf_hyps gl) (m-1)
+ with Failure _ -> error "No such assumption.") gl
+
(* apply a tactic to the last element of the signature *)
let tclLAST_HYP = tclNTH_HYP 1
+let tclLAST_DECL = tclNTH_DECL 1
+
let tclLAST_NHYPS n tac gl =
tac (try list_firstn n (pf_ids_of_hyps gl)
with Failure _ -> error "No such assumptions.") gl
@@ -206,7 +213,7 @@ let onHyps find tac gl = tac (find gl) gl
after id *)
let afterHyp id gl =
- fst (list_splitby (fun (hyp,_,_) -> hyp = id) (pf_hyps gl))
+ fst (list_split_at (fun (hyp,_,_) -> hyp = id) (pf_hyps gl))
(* Create a singleton clause list with the last hypothesis from then context *)
@@ -276,6 +283,13 @@ type branch_assumptions = {
ba : branch_args; (* the branch args *)
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
+ names and "[ ]" for no clause at all *)
+ (* 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
@@ -288,10 +302,11 @@ let compute_induction_names n = function
| None ->
Array.make n []
| Some (loc,IntroOrAndPattern names) ->
+ let names = fix_empty_or_and_pattern n names in
check_or_and_pattern_size loc names n;
Array.of_list names
- | _ ->
- error "Unexpected introduction pattern."
+ | Some (loc,_) ->
+ user_err_loc (loc,"",str "Disjunctive/conjunctive introduction pattern expected.")
let compute_construtor_signatures isrec (_,k as ity) =
let rec analrec c recargs =
@@ -313,23 +328,14 @@ let compute_construtor_signatures isrec (_,k as ity) =
array_map2 analrec lc lrecargs
let elimination_sort_of_goal gl =
- match kind_of_term (hnf_type_of gl (pf_concl gl)) with
- | Sort s ->
- (match s with
- | Prop Null -> InProp
- | Prop Pos -> InSet
- | Type _ -> InType)
- | _ -> anomaly "goal should be a type"
+ pf_apply Retyping.get_sort_family_of gl (pf_concl gl)
let elimination_sort_of_hyp id gl =
- match kind_of_term (hnf_type_of gl (pf_get_hyp_typ gl id)) with
- | Sort s ->
- (match s with
- | Prop Null -> InProp
- | Prop Pos -> InSet
- | Type _ -> InType)
- | _ -> anomaly "goal should be a type"
+ 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
+ | 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 *)
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 6826977b..25a0d897 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 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id: tacticals.mli 11735 2009-01-02 17:22:31Z herbelin $ i*)
(*i*)
open Pp
@@ -28,6 +28,7 @@ open Tacexpr
val tclNORMEVAR : tactic
val tclIDTAC : tactic
val tclIDTAC_MESSAGE : std_ppcmds -> tactic
+val tclORELSE0 : tactic -> tactic -> tactic
val tclORELSE : tactic -> tactic -> tactic
val tclTHEN : tactic -> tactic -> tactic
val tclTHENSEQ : tactic list -> tactic
@@ -57,8 +58,10 @@ 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
@@ -136,6 +139,10 @@ type branch_assumptions = {
val check_or_and_pattern_size :
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 ->
+ or_and_intro_pattern_expr
+
(* Useful for [as intro_pattern] modifier *)
val compute_induction_names :
int -> intro_pattern_expr located option ->
@@ -143,6 +150,7 @@ val compute_induction_names :
val elimination_sort_of_goal : goal sigma -> sorts_family
val elimination_sort_of_hyp : identifier -> goal sigma -> sorts_family
+val elimination_sort_of_clause : identifier option -> goal sigma -> sorts_family
val general_elim_then_using :
(inductive -> goal sigma -> constr) -> rec_flag ->
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index b02e84e7..5af5c0d5 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: tactics.ml 11309 2008-08-06 10:30:35Z herbelin $ *)
+(* $Id: tactics.ml 11745 2009-01-04 18:43:08Z herbelin $ *)
open Pp
open Util
@@ -85,15 +85,6 @@ let dloc = dummy_loc
(* General functions *)
(****************************************)
-(*
-let get_pairs_from_bindings =
- let pair_from_binding = function
- | [(Bindings binds)] -> binds
- | _ -> error "not a binding list!"
- in
- List.map pair_from_binding
-*)
-
let string_of_inductive c =
try match kind_of_term c with
| Ind ind_sp ->
@@ -102,26 +93,16 @@ let string_of_inductive c =
| _ -> raise Bound
with Bound -> error "Bound head variable."
-let rec head_constr_bound t l =
- let t = strip_outer_cast(collapse_appl t) in
- match kind_of_term t with
- | Prod (_,_,c2) -> head_constr_bound c2 l
- | LetIn (_,_,_,c2) -> head_constr_bound c2 l
- | App (f,args) ->
- head_constr_bound f (Array.fold_right (fun a l -> a::l) args l)
- | Const _ -> t::l
- | Ind _ -> t::l
- | Construct _ -> t::l
- | Var _ -> t::l
- | _ -> raise Bound
+let rec head_constr_bound t =
+ let t = strip_outer_cast t in
+ let _,ccl = decompose_prod_assum t in
+ let hd,args = decompose_app ccl in
+ match kind_of_term hd with
+ | Const _ | Ind _ | Construct _ | Var _ -> (hd,args)
+ | _ -> raise Bound
let head_constr c =
- try head_constr_bound c [] with Bound -> error "Bound head variable."
-
-(*
-let bad_tactic_args s l =
- raise (RefinerError (BadTacticArgs (s,l)))
-*)
+ try head_constr_bound c with Bound -> error "Bound head variable."
(******************************************)
(* Primitive tactics *)
@@ -169,6 +150,8 @@ let internal_cut_rev_replace = internal_cut_rev_gen true
(* Moving hypotheses *)
let move_hyp = Tacmach.move_hyp
+let order_hyps = Tacmach.order_hyps
+
(* Renaming hypotheses *)
let rename_hyp = Tacmach.rename_hyp
@@ -192,25 +175,28 @@ let cofix = function
type tactic_reduction = env -> evar_map -> constr -> constr
-(* The following two tactics apply an arbitrary
- reduction function either to the conclusion or to a
- certain hypothesis *)
-
-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 (_,c, ty) = pf_get_hyp gl id in
+let pf_reduce_decl redfun where (id,c,ty) gl =
let redfun' = pf_reduce redfun gl in
match c with
| None ->
if where = InHypValueOnly then
errorlabstrm "" (pr_id id ++ str "has no value.");
- convert_hyp_no_check (id,None,redfun' ty) gl
+ (id,None,redfun' ty)
| Some b ->
let b' = if where <> InHypTypeOnly then redfun' b else b in
let ty' = if where <> InHypValueOnly then redfun' ty else ty in
- convert_hyp_no_check (id,Some b',ty') gl
+ (id,Some b',ty')
+
+(* The following two tactics apply an arbitrary
+ reduction function either to the conclusion or to a
+ certain hypothesis *)
+
+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 =
+ convert_hyp_no_check
+ (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
@@ -238,8 +224,8 @@ let change_on_subterm cv_pb t = function
let change_in_concl occl t =
reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast)
-let change_in_hyp occl t =
- reduct_in_hyp (change_on_subterm Reduction.CONV t occl)
+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
@@ -276,16 +262,18 @@ let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast)
(* A function which reduces accordingly to a reduction expression,
as the command Eval does. *)
-let needs_check = function
+let checking_fun = function
(* Expansion is not necessarily well-typed: e.g. expansion of t into x is
not well-typed in [H:(P t); x:=t |- G] because x is defined after H *)
- | Fold _ -> true
- | _ -> false
+ | Fold _ -> with_check
+ | Pattern _ -> with_check
+ | _ -> (fun x -> x)
let reduce redexp cl goal =
- (if needs_check redexp then with_check else (fun x -> x))
- (redin_combinator (Redexpr.reduction_of_red_expr redexp) cl)
- goal
+ let red = Redexpr.reduction_of_red_expr redexp in
+ match redexp with
+ (Fold _|Pattern _) -> with_check (redin_combinator red cl) goal
+ | _ -> redin_combinator red cl goal
(* Unfolding occurrences of a constant *)
@@ -402,9 +390,26 @@ let rec get_next_hyp_position id = function
else
get_next_hyp_position id right
+let thin_for_replacing l gl =
+ try Tacmach.thin l gl
+ with Evarutil.ClearDependencyError (id,err) -> match err with
+ | Evarutil.OccurHypInSimpleClause None ->
+ errorlabstrm ""
+ (str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion.")
+ | Evarutil.OccurHypInSimpleClause (Some id') ->
+ errorlabstrm ""
+ (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 " ++
+ Printer.pr_existential (pf_env gl) ev ++ str".")
+
let intro_replacing id gl =
let next_hyp = get_next_hyp_position id (pf_hyps gl) in
- tclTHENLIST [thin [id]; introduction id; move_hyp true id next_hyp] gl
+ tclTHENLIST
+ [thin_for_replacing [id]; introduction id; move_hyp true id next_hyp] gl
let intros_replacing ids gl =
let rec introrec = function
@@ -518,6 +523,13 @@ let bring_hyps hyps =
let f = mkCast (Evarutil.mk_new_meta(),DEFAULTcast, newcl) in
refine_no_check (mkApp (f, instance_from_named_context hyps)) gl)
+let resolve_classes gl =
+ let env = pf_env gl and evd = project gl in
+ 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
+
(**************************)
(* Cut tactics *)
(**************************)
@@ -535,17 +547,11 @@ let cut c gl =
let cut_intro t = tclTHENFIRST (cut t) intro
-(* let cut_replacing id t tac =
- tclTHENS (cut t)
- [tclORELSE
- (intro_replacing id)
- (tclORELSE (intro_erasing id) (intro_using id));
- tac (refine_no_check (mkVar id)) ] *)
-
(* 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 =
- tclTHENS (cut t) [ intro_replacing id; tac (refine_no_check (mkVar id)) ]
+ tclTHENLAST (internal_cut_rev_replace id t)
+ (tac (refine_no_check (mkVar id)))
let cut_in_parallel l =
let rec prec = function
@@ -704,72 +710,88 @@ 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 =
+ 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 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
+ | None ->
+ raise Exit
+ with RefinerError _|UserError _|Exit -> exit ()
+
(****************************************************)
(* Resolution tactics *)
(****************************************************)
-let resolve_classes gl =
- let env = pf_env gl and evd = project gl in
- 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
-
(* Resolution with missing arguments *)
-let general_apply with_delta with_destruct with_evars (c,lbind) gl =
+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 =
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 gl) in
+ let concl_nprod = nb_prod (pf_concl gl0) in
+ let evm, c = c in
let rec try_main_apply c gl =
- let thm_ty0 = nf_betaiota (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
- 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 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 ->
- (* 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
- try
- let (mind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
- match match_with_conjunction (snd (decompose_prod t)) with
- | Some _ ->
- let n = (mis_constr_nargs mind).(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 (try_main_apply (mkVar id)) (thin l)) l))
- ]) gl
- | None ->
- raise Exit
- with RefinerError _|UserError _|Exit -> raise exn
- else
- raise exn
- in
- try_red_apply thm_ty0 in
- try_main_apply c gl
+ let thm_ty0 = nf_betaiota (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
+ in
+ try try_apply thm_ty0 concl_nprod
+ with PretypeError _|RefinerError _|UserError _|Failure _ as exn ->
+ let rec try_red_apply thm_ty =
+ 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 ->
+ (* 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
+ else
+ raise 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
let rec apply_with_ebindings_gen b e = function
| [] ->
@@ -783,13 +805,13 @@ 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 (c,bl) =
- apply_with_ebindings (c,inj_ebindings bl)
+ apply_with_ebindings (inj_open c,inj_ebindings bl)
let eapply_with_bindings (c,bl) =
- apply_with_ebindings_gen false true [c,inj_ebindings bl]
+ apply_with_ebindings_gen false true [inj_open c,inj_ebindings bl]
let apply c =
- apply_with_ebindings (c,NoBindings)
+ apply_with_ebindings (inj_open c,NoBindings)
let apply_list = function
| c::l -> apply_with_bindings (c,ImplicitBindings l)
@@ -819,27 +841,43 @@ let find_matching_clause unifier clause =
with NotExtensibleClause -> failwith "Cannot apply"
in find clause
-let progress_with_clause innerclause clause =
+let progress_with_clause flags innerclause clause =
let ordered_metas = List.rev (clenv_independent clause) in
if ordered_metas = [] then error "Statement without assumptions.";
- let f mv = find_matching_clause (clenv_fchain mv clause) innerclause in
+ let f mv =
+ find_matching_clause (clenv_fchain mv ~flags clause) innerclause in
try list_try_find f ordered_metas
with Failure _ -> error "Unable to unify."
-let apply_in_once gl innerclause (d,lbind) =
+let apply_in_once_main flags innerclause (d,lbind) gl =
let thm = nf_betaiota (pf_type_of gl d) in
let rec aux clause =
- try progress_with_clause innerclause clause
+ try progress_with_clause flags innerclause clause
with err ->
try aux (clenv_push_prod clause)
- with NotExtensibleClause -> raise err
- in aux (make_clenv_binding gl (d,thm) lbind)
+ 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 =
+ 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 =
+ 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
+ with exn when with_destruct ->
+ descend_in_conjunctions true 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
+
+
-let apply_in with_evars id lemmas gl =
- let t' = pf_get_hyp_typ gl id in
- let innermostclause = mk_clenv_from_n gl (Some 0) (mkVar id,t') in
- let clause = List.fold_left (apply_in_once gl) innermostclause lemmas in
- clenv_refine_in with_evars id clause gl
(* A useful resolution tactic which, if c:A->B, transforms |- C into
|- B -> C and |- A
@@ -1013,7 +1051,7 @@ let constructor_tac with_evars expctdnumopt i lbind gl =
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 (cons,lbind) in
+ let apply_tac = general_apply true false with_evars (inj_open cons,lbind) in
(tclTHENLIST
[convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl
@@ -1062,11 +1100,6 @@ let register_general_multi_rewrite f =
let clear_last = tclLAST_HYP (fun c -> (clear [destVar c]))
let case_last = tclLAST_HYP simplest_case
-let fix_empty_case nv l =
- (* The syntax does not distinguish between "[ ]" for one clause with no names
- and "[ ]" for no clause at all; so we are a bit liberal here *)
- if Array.length nv = 0 & l = [[]] then [] else l
-
let error_unexpected_extra_pattern loc nb pat =
let s1,s2,s3 = match pat with
| IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no"
@@ -1089,7 +1122,7 @@ let intro_or_and_pattern loc b ll l' tac =
if bracketed then error_unexpected_extra_pattern loc' nb pat;
l
| ip :: l -> ip :: adjust_names_length nb (n-1) l in
- let ll = fix_empty_case nv ll in
+ let ll = fix_empty_or_and_pattern (Array.length nv) ll in
check_or_and_pattern_size loc ll (Array.length nv);
tclTHENLASTn
(tclTHEN case_last clear_last)
@@ -1097,12 +1130,29 @@ let intro_or_and_pattern loc b ll l' tac =
nv (Array.of_list ll))
gl)
-let clear_if_atomic l2r id gl =
- let eq = pf_type_of gl (mkVar id) in
- let (_,lhs,rhs) = snd (find_eq_data_decompose eq) in
- if l2r & isVar lhs then tclTRY (clear [destVar lhs;id]) gl
- else if not l2r & isVar rhs then tclTRY (clear [destVar rhs;id]) gl
- else tclIDTAC gl
+let rewrite_hyp l2r id gl =
+ let rew_on l2r =
+ !forward_general_multi_rewrite l2r false (inj_open (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
+ (* TODO: detect setoid equality? better detect the different equalities *)
+ 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
+ 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
+ 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
+ else
+ tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl
+ | _ ->
+ error "Cannot find a known equation."
let rec explicit_intro_names = function
| (_, IntroIdentifier id) :: l ->
@@ -1149,11 +1199,9 @@ let rec intros_patterns b avoid thin destopt = function
tclTHEN
(intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true)
(onLastHyp (fun id ->
- tclTHENLIST [
- !forward_general_multi_rewrite l2r false (mkVar id,NoBindings)
- allClauses;
- clear_if_atomic l2r id;
- intros_patterns b avoid thin destopt l ]))
+ tclTHEN
+ (rewrite_hyp l2r id)
+ (intros_patterns b avoid thin destopt l)))
| [] -> clear_wildcards thin
let intros_pattern = intros_patterns false [] []
@@ -1170,23 +1218,25 @@ let intro_patterns = function
let make_id s = fresh_id [] (default_id_of_sort s)
-let prepare_intros s (loc,ipat) gl = match ipat with
+let prepare_intros s ipat gl = match ipat with
+ | None -> make_id s gl, tclIDTAC
+ | Some (loc,ipat) -> match ipat with
| IntroIdentifier id -> id, tclIDTAC
| 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 ->
let id = make_id s gl in
- id, !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allClauses
+ id, !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allClauses
| IntroOrAndPattern ll -> make_id s gl,
intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move)
let ipat_of_name = function
- | Anonymous -> IntroAnonymous
- | Name id -> IntroIdentifier id
+ | Anonymous -> None
+ | Name id -> Some (dloc, IntroIdentifier id)
let allow_replace c gl = function (* A rather arbitrary condition... *)
- | _, IntroIdentifier id ->
+ | Some (_, IntroIdentifier id) ->
fst (decompose_app (snd (decompose_lam_assum c))) = mkVar id
| _ ->
false
@@ -1201,15 +1251,37 @@ let assert_as first ipat c gl =
(if first then [tclIDTAC; tac] else [tac; tclIDTAC]) gl
| _ -> error "Not a proposition or a type."
-let assert_tac first na = assert_as first (dloc,ipat_of_name na)
-let true_cut = assert_tac true
+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,IntroOrAndPattern ll) ->
+ intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move)
+ | Some (loc,
+ (IntroIdentifier _ | IntroAnonymous | IntroFresh _ | IntroWildcard)) ->
+ 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 apply_in simple with_evars = general_apply_in simple simple with_evars
(**************************)
(* Generalize tactics *)
(**************************)
-let generalized_name c t cl = function
- | Name id as na -> na
+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");
+ na
| Anonymous ->
match kind_of_term c with
| Var id ->
@@ -1228,7 +1300,7 @@ let generalize_goal gl i ((occs,c),na) cl =
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 cl' na in
+ let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in
mkProd (na,t,cl')
let generalize_dep c gl =
@@ -1313,10 +1385,10 @@ let out_arg = function
let occurrences_of_hyp id cls =
let rec hyp_occ = function
[] -> None
- | (((b,occs),id'),hl)::_ when id=id' -> Some (b,List.map out_arg occs)
+ | (((b,occs),id'),hl)::_ when id=id' -> Some ((b,List.map out_arg occs),hl)
| _::l -> hyp_occ l in
match cls.onhyps with
- None -> Some (all_occurrences)
+ None -> Some (all_occurrences,InHyp)
| Some l -> hyp_occ l
let occurrences_of_goal cls =
@@ -1383,15 +1455,15 @@ let letin_tac with_eq name c occs gl =
(* Implementation without generalisation: abbrev will be lost in hyps in *)
(* in the extracted proof *)
-let letin_abstract id c occs gl =
+let letin_abstract id c (occs,check_occs) gl =
let env = pf_env gl in
let compute_dependency _ (hyp,_,_ as d) depdecls =
match occurrences_of_hyp hyp occs with
| None -> depdecls
| Some occ ->
let newdecl = subst_term_occ_decl occ c d in
- if occ = all_occurrences & d = newdecl then
- if not (in_every_hyp occs)
+ if occ = (all_occurrences,InHyp) & d = newdecl then
+ if check_occs & not (in_every_hyp occs)
then raise (RefinerError (DoesNotOccurIn (c,hyp)))
else depdecls
else
@@ -1404,14 +1476,14 @@ let letin_abstract id c occs gl =
if depdecls = [] then no_move else MoveAfter(pi1(list_last depdecls)) in
(depdecls,lastlhyp,ccl)
-let letin_tac with_eq name c occs gl =
+let letin_tac_gen with_eq name c ty occs gl =
let id =
let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in
if name = Anonymous then fresh_id [] x gl else
if not (mem_named_context x (pf_hyps gl)) then x else
error ("The variable "^(string_of_id x)^" is already declared.") in
let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in
- let t = pf_type_of gl c 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)) ->
let heq = match ido with
@@ -1434,7 +1506,10 @@ let letin_tac with_eq name c occs gl =
intro_gen dloc (IntroMustBe id) lastlhyp true;
eq_tac;
tclMAP convert_hyp_no_check depdecls ] gl
-
+
+let letin_tac with_eq name c ty occs =
+ letin_tac_gen with_eq name c ty (occs,true)
+
(* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *)
let forward usetac ipat c gl =
match usetac with
@@ -1444,6 +1519,9 @@ let forward usetac ipat c gl =
| Some tac ->
tclTHENFIRST (assert_as true ipat c) tac gl
+let pose_proof na c = forward None (ipat_of_name na) c
+let assert_by na t tac = forward (Some tac) (ipat_of_name na) t
+
(*****************************)
(* Ad hoc unfold *)
(*****************************)
@@ -1523,7 +1601,7 @@ let rec first_name_buggy avoid gl (loc,pat) = match pat with
| IntroWildcard -> no_move
| IntroRewrite _ -> no_move
| IntroIdentifier id -> MoveAfter id
- | IntroAnonymous | IntroFresh _ -> assert false
+ | IntroAnonymous | IntroFresh _ -> (* buggy *) no_move
let consume_pattern avoid id gl = function
| [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), [])
@@ -1618,14 +1696,14 @@ 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) allClauses)
+ (letin_tac None (Name x) (mkVar id) None allClauses)
(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 allClauses)
+ (letin_tac None (Name x) c None allClauses)
(atomize_one (i-1) ((mkVar x)::avoid)) gl
else
tclIDTAC gl
@@ -1712,11 +1790,11 @@ let find_atomic_param_of_ind nparams indtyp =
exception Shunt of identifier move_location
-let cook_sign hyp0_opt indvars_init env =
- let hyp0,indvars =
- match hyp0_opt with
- | None -> List.hd (List.rev indvars_init) , indvars_init
- | Some h -> h,indvars_init in
+let cook_sign hyp0_opt indvars env =
+ let hyp0,inhyps =
+ match hyp0_opt with
+ | None -> List.hd (List.rev indvars), []
+ | Some (hyp0,at_least_in_hyps) -> hyp0, at_least_in_hyps in
(* First phase from L to R: get [indhyps], [decldep] and [statuslist]
for the hypotheses before (= more ancient than) hyp0 (see above) *)
let allindhyps = hyp0::indvars in
@@ -1739,9 +1817,9 @@ let cook_sign hyp0_opt indvars_init env =
indhyps := hyp::!indhyps;
rhyp
end else
- if (List.exists (fun id -> occur_var_in_decl env id decl) allindhyps
- or List.exists (fun (id,_,_) -> occur_var_in_decl env id decl)
- !decldeps)
+ if inhyps <> [] && List.mem hyp inhyps || inhyps = [] &&
+ (List.exists (fun id -> occur_var_in_decl env id decl) allindhyps ||
+ List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps)
then begin
decldeps := decl::!decldeps;
if !before then
@@ -1909,14 +1987,26 @@ let mkEq t x y =
let mkRefl t x =
mkApp ((build_coq_eq_data ()).refl, [| t; x |])
-let mkHEq t x u y =
+let mkHEq t x u y =
mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq",
[| t; x; u; y |])
-let mkHRefl t x =
+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 |])
@@ -1936,40 +2026,46 @@ let ids_of_constr 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
+ | App (f, args) ->
+ (match kind_of_term f with
+ | Construct (ind,_)
+ | Ind ind ->
+ let (mib,mip) = Global.lookup_inductive ind in
+ array_fold_left_from mib.Declarations.mind_nparams
+ aux vars args
+ | _ -> fold_constr aux vars c)
| _ -> fold_constr aux vars c
in aux vars c
let make_abstract_generalize gl id concl dep ctx c eqs args refls =
let meta = Evarutil.new_meta() in
- let cstr =
+ let term, typ = mkVar id, pf_get_hyp_typ gl id in
+ let eqslen = List.length eqs 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
+ in
(* Abstract by equalitites *)
- let eqs = lift_togethern 1 eqs in
- let abseqs = it_mkProd_or_LetIn ~init:concl (List.map (fun x -> (Anonymous, None, x)) eqs) in
- (* Abstract by the "generalized" hypothesis and its equality proof *)
- let term, typ = mkVar id, pf_get_hyp_typ gl id in
- let abshyp =
- let abshypeq =
- if dep then
- mkProd (Anonymous, mkHEq (lift 1 c) (mkRel 1) typ term, lift 1 abseqs)
- else abseqs
- in
- mkProd (Name id, c, abshypeq)
- in
- (* Abstract by the extension of the context *)
- let genctyp = it_mkProd_or_LetIn ~init:abshyp ctx in
- (* The goal will become this product. *)
- let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in
- (* Apply the old arguments giving the proper instantiation of the hyp *)
- let instc = mkApp (genc, Array.of_list args) in
- (* Then apply to the original instanciated hyp. *)
- let newc = mkApp (instc, [| mkVar id |]) in
- (* Apply the reflexivity proof for the original hyp. *)
- let newc = if dep then mkApp (newc, [| mkHRefl typ term |]) else newc in
- (* Finaly, apply the remaining reflexivity proofs on the index, to get a term of type gl again *)
- let appeqs = mkApp (newc, Array.of_list refls) in
- appeqs
- in cstr
-
+ 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
+ (* 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
+ (* 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
+ (* 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
+
let abstract_args gl id =
let c = pf_get_hyp_typ gl id in
let sigma = project gl in
@@ -1998,26 +2094,36 @@ let abstract_args gl id =
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)
+ | 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
@@ -2040,10 +2146,31 @@ let abstract_generalize id ?(generalize_vars=true) gl =
else
tclTHENLIST [refine newc; clear [id]; tclDO n intro]
in
- if generalize_vars then
- tclTHEN tac (tclMAP (fun id -> tclTRY (generalize_dep (mkVar id))) vars) gl
+ 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
+ in
+ let subst = (c, varname c, cty) :: List.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 occur_rel n c =
let res = not (noccurn n c) in
res
@@ -2466,7 +2593,8 @@ let induction_from_context_l isrec with_evars elim_info lid names gl =
apply_induction_in_context isrec
None indsign (hyp0::indvars) names induct_tac gl
-let induction_from_context isrec with_evars elim_info (hyp0,lbind) names gl =
+let induction_from_context isrec with_evars elim_info (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
@@ -2479,12 +2607,11 @@ let induction_from_context isrec with_evars elim_info (hyp0,lbind) names gl =
thin [hyp0]
] in
apply_induction_in_context isrec
- (Some hyp0) indsign indvars names induct_tac gl
-
+ (Some (hyp0,inhyps)) indsign indvars names induct_tac gl
exception TryNewInduct of exn
-let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) 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
@@ -2494,7 +2621,8 @@ let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbin
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) gl
+ (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
@@ -2512,26 +2640,66 @@ let induction_without_atomization isrec with_evars elim names lid gl =
then error "Not the right number of induction arguments."
else induction_from_context_l isrec with_evars elim_info lid names gl
+let enforce_eq_name id gl = function
+ | (b,(loc,IntroAnonymous)) ->
+ (b,(loc,IntroIdentifier (fresh_id [id] (add_prefix "Heq" id) gl)))
+ | (b,(loc,IntroFresh heq_base)) ->
+ (b,(loc,IntroIdentifier (fresh_id [id] heq_base gl)))
+ | x ->
+ x
+
+let has_selected_occurrences = function
+ | None -> false
+ | Some cls ->
+ cls.concl_occs <> all_occurrences_expr ||
+ cls.onhyps <> None && List.exists (fun ((occs,_),hl) ->
+ occs <> all_occurrences_expr || hl <> InHyp) (Option.get cls.onhyps)
+
+(* assume that no occurrences are selected *)
+let clear_unselected_context id inhyps cls gl =
+ match cls with
+ | None -> tclIDTAC gl
+ | Some cls ->
+ if occur_var (pf_env gl) id (pf_concl gl) &&
+ cls.concl_occs = no_occurrences_expr
+ then errorlabstrm ""
+ (str "Conclusion must be mentioned: it depends on " ++ pr_id id
+ ++ str ".");
+ match cls.onhyps with
+ | Some hyps ->
+ let to_erase (id',_,_ as d) =
+ if List.mem id' inhyps then (* if selected, do not erase *) None
+ else
+ (* erase if not selected and dependent on id or selected hyps *)
+ let test id = occur_var_in_decl (pf_env gl) id d in
+ if List.exists test (id::inhyps) then Some id' else None in
+ let ids = list_map_filter to_erase (pf_hyps gl) in
+ thin ids gl
+ | None -> tclIDTAC gl
+
let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl =
+ let inhyps = match cls with
+ | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps
+ | _ -> [] in
match kind_of_term c with
| Var id when not (mem_named_context id (Global.named_context()))
- & lbind = NoBindings & not with_evars & cls = None
- & eqname = None ->
- induction_with_atomization_of_ind_arg
- isrec with_evars elim names (id,lbind) gl
+ & 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)
Anonymous in
let id = fresh_id [] x gl in
- let with_eq =
- match eqname with
- | Some eq -> Some (false,eq)
- | _ ->
- if cls <> None then Some (false,(dloc,IntroAnonymous)) else None 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 with_eq (Name id) c (Option.default allClauses cls))
+ (letin_tac_gen with_eq (Name id) c None (Option.default allClauses cls,false))
(induction_with_atomization_of_ind_arg
- isrec with_evars elim names (id,lbind)) gl
+ isrec with_evars elim names (id,lbind) inhyps) gl
(* Induction on a list of arguments. First make induction arguments
atomic (using letins), then do induction. The specificity here is
@@ -2563,7 +2731,7 @@ let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl =
let _ = newlc:=id::!newlc in
let _ = letids:=id::!letids in
tclTHEN
- (letin_tac None (Name id) c allClauses)
+ (letin_tac None (Name id) c None allClauses)
(atomize_list newl') gl in
tclTHENLIST
[
@@ -2763,12 +2931,15 @@ let reflexivity_red allowred gl =
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 -> !setoid_reflexivity gl
- | Some _ -> one_constructor 1 NoBindings gl
-
-let reflexivity gl = reflexivity_red false gl
-
+ match match_with_equality_type concl with
+ | None -> None
+ | Some _ -> Some (one_constructor 1 NoBindings)
+
+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 *)
@@ -2788,13 +2959,15 @@ let symmetry_red allowred gl =
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 -> !setoid_symmetry gl
- | Some (hdcncl,args) ->
+ match match_with_equation concl with
+ | None -> None
+ | Some (hdcncl,args) -> Some (fun gl ->
let hdcncls = string_of_inductive hdcncl in
begin
try
- (apply (pf_parse_const gl ("sym_"^hdcncls)) gl)
+ 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 |])
@@ -2808,9 +2981,12 @@ let symmetry_red allowred gl =
tclLAST_HYP simplest_case;
one_constructor 1 NoBindings ])
gl
- end
+ end)
-let symmetry gl = symmetry_red false gl
+let symmetry gl =
+ match symmetry_red false gl with
+ | None -> !setoid_symmetry gl
+ | Some tac -> tac gl
let setoid_symmetry_in = ref (fun _ _ -> assert false)
let register_setoid_symmetry_in f = setoid_symmetry_in := f
@@ -2860,8 +3036,8 @@ let transitivity_red allowred t gl =
else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl)
in
match match_with_equation concl with
- | None -> !setoid_transitivity t gl
- | Some (hdcncl,args) ->
+ | None -> None
+ | Some (hdcncl,args) -> Some (fun gl ->
let hdcncls = string_of_inductive hdcncl in
begin
try
@@ -2885,10 +3061,13 @@ let transitivity_red allowred t gl =
[ tclDO 2 intro;
tclLAST_HYP simplest_case;
assumption ])) gl
- end
-
-let transitivity t gl = transitivity_red false t 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
@@ -2917,7 +3096,7 @@ let abstract_subproof name tac gl =
error "\"abstract\" cannot handle existentials.";
let lemme =
start_proof na (Global, Proof Lemma) secsign concl (fun _ _ -> ());
- let _,(const,kind,_) =
+ let _,(const,_,kind,_) =
try
by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac));
let r = cook_proof ignore in
@@ -2968,7 +3147,14 @@ let admit_as_an_axiom gl =
List.rev (Array.to_list (instance_from_named_context sign))))
gl
-let conv x y gl =
- try let evd = Evarconv.the_conv_x_leq (pf_env gl) x y (Evd.create_evar_defs (project gl)) in
- tclEVARS (Evd.evars_of evd) gl
- with _ -> tclFAIL 0 (str"Not convertible") gl
+let unify ?(state=full_transparent_state) x y gl =
+ try
+ let flags =
+ {default_unify_flags with
+ modulo_delta = state;
+ modulo_conv_on_closed_terms = Some state}
+ in
+ 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
+ with _ -> tclFAIL 0 (str"Not unifiable") gl
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index d39433d0..fb5c0efd 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 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id: tactics.mli 11735 2009-01-02 17:22:31Z herbelin $ i*)
(*i*)
open Util
@@ -42,8 +42,8 @@ val type_clenv_binding : goal sigma ->
constr * constr -> open_constr bindings -> constr
val string_of_inductive : constr -> string
-val head_constr : constr -> constr list
-val head_constr_bound : constr -> constr list -> constr list
+val head_constr : constr -> constr * constr list
+val head_constr_bound : constr -> constr * constr list
val is_quantified_hypothesis : identifier -> goal sigma -> bool
exception Bound
@@ -184,19 +184,22 @@ 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 -> constr with_ebindings list -> tactic
+ advanced_flag -> evars_flag -> open_constr with_ebindings list -> tactic
val apply_with_bindings : constr with_bindings -> tactic
val eapply_with_bindings : constr with_bindings -> tactic
-val apply_with_ebindings : constr with_ebindings -> tactic
-val eapply_with_ebindings : constr with_ebindings -> 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 : evars_flag -> identifier -> constr with_ebindings list -> tactic
+val apply_in :
+ advanced_flag -> evars_flag -> identifier ->
+ open_constr with_ebindings list ->
+ intro_pattern_expr located option -> tactic
(*s Elimination tactics. *)
@@ -324,19 +327,19 @@ val simplest_split : tactic
(*s Logical connective tactics. *)
val register_setoid_reflexivity : tactic -> unit
-val reflexivity_red : bool -> tactic
+val reflexivity_red : bool -> goal sigma -> tactic option
val reflexivity : tactic
val intros_reflexivity : tactic
val register_setoid_symmetry : tactic -> unit
-val symmetry_red : bool -> tactic
+val symmetry_red : bool -> goal sigma -> tactic option
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 -> tactic
+val transitivity_red : bool -> constr -> goal sigma -> tactic option
val transitivity : constr -> tactic
val intros_transitivity : constr -> tactic
@@ -346,17 +349,19 @@ val cut_replacing :
identifier -> constr -> (tactic -> tactic) -> tactic
val cut_in_parallel : constr list -> tactic
-val assert_as : bool -> intro_pattern_expr located -> constr -> tactic
-val forward : tactic option -> intro_pattern_expr located -> constr -> 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 ->
- constr -> clause -> tactic
-val true_cut : name -> constr -> tactic
-val assert_tac : bool -> name -> constr -> tactic
+ constr -> types option -> clause -> tactic
+val assert_tac : name -> types -> tactic
+val assert_by : name -> types -> tactic -> tactic
+val pose_proof : name -> constr -> tactic
+
val generalize : constr list -> tactic
val generalize_gen : ((occurrences * constr) * name) list -> tactic
val generalize_dep : constr -> tactic
-val conv : constr -> constr -> tactic
+val unify : ?state:Names.transparent_state -> constr -> constr -> tactic
val resolve_classes : tactic
val tclABSTRACT : identifier option -> tactic -> tactic
@@ -365,5 +370,7 @@ val admit_as_an_axiom : tactic
val abstract_generalize : identifier -> ?generalize_vars:bool -> tactic
+val dependent_pattern : constr -> tactic
+
val register_general_multi_rewrite :
- (bool -> evars_flag -> constr with_ebindings -> clause -> tactic) -> unit
+ (bool -> evars_flag -> open_constr with_bindings -> clause -> tactic) -> unit
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index 17ea121f..1729695d 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(*i $Id: tauto.ml4 11309 2008-08-06 10:30:35Z herbelin $ i*)
+(*i $Id: tauto.ml4 11739 2009-01-02 19:33:19Z herbelin $ i*)
open Term
open Hipattern
@@ -21,19 +21,44 @@ open Tacinterp
open Tactics
open Util
-let assoc_last ist =
- match List.assoc (Names.id_of_string "X1") ist.lfun with
+let assoc_var s ist =
+ match List.assoc (Names.id_of_string s) ist.lfun with
| VConstr c -> c
| _ -> failwith "tauto: anomaly"
+(** Parametrization of tauto *)
+
+(* Whether conjunction and disjunction are restricted to binary connectives *)
+(* (this is the compatibility mode) *)
+let binary_mode = true
+
+(* Whether conjunction and disjunction are restricted to the connectives *)
+(* having the structure of "and" and "or" (up to the choice of sorts) in *)
+(* contravariant position in an hypothesis (this is the compatibility mode) *)
+let strict_in_contravariant_hyp = true
+
+(* Whether conjunction and disjunction are restricted to the connectives *)
+(* having the structure of "and" and "or" (up to the choice of sorts) in *)
+(* an hypothesis and in the conclusion *)
+let strict_in_hyp_and_ccl = false
+
+(* Whether unit type includes equality types *)
+let strict_unit = false
+
+
+(** Test *)
+
let is_empty ist =
- if is_empty_type (assoc_last ist) then
+ if is_empty_type (assoc_var "X1" ist) then
<:tactic<idtac>>
else
<:tactic<fail>>
-let is_unit ist =
- if is_unit_type (assoc_last ist) then
+(* Strictly speaking, this exceeds the propositional fragment as it
+ matches also equality types (and solves them if a reflexivity) *)
+let is_unit_or_eq ist =
+ let test = if strict_unit then is_unit_type else is_unit_or_eq_type in
+ if test (assoc_var "X1" ist) then
<:tactic<idtac>>
else
<:tactic<fail>>
@@ -47,93 +72,138 @@ let is_record t =
| _ -> false
let is_binary t =
+ isApp t &&
let (hdapp,args) = decompose_app t in
match (kind_of_term hdapp) with
| 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
+
+(** Dealing with conjunction *)
+
let is_conj ist =
- let ind = assoc_last ist in
- if (is_conjunction ind) && (is_nodep_ind ind) (* && not (is_record ind) *)
- && is_binary ind (* for compatibility, as (?X _ _) matches
- applications with 2 or more arguments. *)
+ let ind = assoc_var "X1" ist in
+ if (not binary_mode || is_binary ind) (* && not (is_record ind) *)
+ && is_conjunction ~strict:strict_in_hyp_and_ccl ind
then
<:tactic<idtac>>
else
<:tactic<fail>>
+let flatten_contravariant_conj ist =
+ let typ = assoc_var "X1" ist in
+ let c = assoc_var "X2" ist in
+ 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 intros =
+ iter_tac (List.map (fun _ -> <:tactic< intro >>) args)
+ <:tactic< idtac >> in
+ <:tactic<
+ let newtyp := $newtyp in
+ assert newtyp by ($intros; apply id; split; assumption);
+ clear id
+ >>
+ else
+ <:tactic<fail>>
+ | _ ->
+ <:tactic<fail>>
+
+(** Dealing with disjunction *)
+
let is_disj ist =
- if is_disjunction (assoc_last ist) && is_binary (assoc_last ist) then
+ let t = assoc_var "X1" ist in
+ if (not binary_mode || is_binary t) &&
+ is_disjunction ~strict:strict_in_hyp_and_ccl t
+ then
<:tactic<idtac>>
else
<:tactic<fail>>
+let flatten_contravariant_disj ist =
+ let typ = assoc_var "X1" ist in
+ let c = assoc_var "X2" ist in
+ 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
+ iter_tac (list_map_i (fun i arg ->
+ let typ = valueIn (VConstr (mkArrow arg c)) in
+ <:tactic<
+ let typ := $typ in
+ assert typ by (intro; apply id; constructor $i; assumption)
+ >>) 1 args) <:tactic< clear id >>
+ else
+ <:tactic<fail>>
+ | _ ->
+ <:tactic<fail>>
+
+
+(** Main tactic *)
+
let not_dep_intros ist =
<:tactic<
repeat match goal with
| |- (?X1 -> ?X2) => intro
- | |- (Coq.Init.Logic.iff _ _) => unfold Coq.Init.Logic.iff
- | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not
- | H:(Coq.Init.Logic.iff _ _)|- _ => unfold Coq.Init.Logic.iff in H
- | H:(Coq.Init.Logic.not _)|-_ => unfold Coq.Init.Logic.not in H
- | H:(Coq.Init.Logic.iff _ _)->_|- _ => unfold Coq.Init.Logic.iff in H
- | H:(Coq.Init.Logic.not _)->_|-_ => unfold Coq.Init.Logic.not in H
+ | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1
+ | 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 = tacticIn is_unit
+ let t_is_unit_or_eq = tacticIn is_unit_or_eq
and t_is_empty = tacticIn is_empty in
<:tactic<
match reverse goal with
- | |- ?X1 => $t_is_unit; constructor 1
+ | |- ?X1 => $t_is_unit_or_eq; constructor 1
| _:?X1 |- _ => $t_is_empty; elimtype X1; assumption
| _:?X1 |- ?X1 => assumption
end >>
let simplif ist =
- let t_is_unit = tacticIn is_unit
+ let t_is_unit_or_eq = tacticIn is_unit_or_eq
and t_is_conj = tacticIn is_conj
+ and t_flatten_contravariant_conj = tacticIn flatten_contravariant_conj
+ and t_flatten_contravariant_disj = tacticIn flatten_contravariant_disj
and t_is_disj = tacticIn is_disj
and t_not_dep_intros = tacticIn not_dep_intros in
<:tactic<
$t_not_dep_intros;
repeat
(match reverse goal with
- | id: (?X1 _ _) |- _ =>
- $t_is_conj; elim id; do 2 intro; clear id
- | id: (?X1 _ _) |- _ => $t_is_disj; elim id; intro; clear id
+ | 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: ?X1 |- _ => $t_is_disj; elim id; intro; clear id
| 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. *)
assert X2; [exact (id0 id1) | clear id0]
| id: ?X1 -> ?X2|- _ =>
- $t_is_unit; cut X2;
+ $t_is_unit_or_eq; cut X2;
[ intro; clear id
| (* id : ?X1 -> ?X2 |- ?X2 *)
cut X1; [exact id| constructor 1; fail]
]
- | id: (?X1 ?X2 ?X3) -> ?X4|- _ =>
- $t_is_conj; cut (X2-> X3-> X4);
- [ intro; clear id
- | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X2 -> ?X3 -> ?X4 *)
- intro; intro; cut (X1 X2 X3); [exact id| split; assumption]
- ]
- | id: (?X1 ?X2 ?X3) -> ?X4|- _ =>
- $t_is_disj;
- cut (X3-> X4);
- [cut (X2-> X4);
- [intro; intro; clear id
- | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X2 -> ?X4 *)
- intro; cut (X1 X2 X3); [exact id| left; assumption]
- ]
- | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X3 -> ?X4 *)
- intro; cut (X1 X2 X3); [exact id| right; assumption]
- ]
- | |- (?X1 _ _) => $t_is_conj; split
+ | id: ?X1 -> ?X2|- _ =>
+ $t_flatten_contravariant_conj
+ (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *)
+ | id: (Coq.Init.Logic.iff ?X1 ?X2) -> ?X3|- _ =>
+ assert ((X1 -> X2) -> (X2 -> X1) -> X3)
+ by (do 2 intro; apply id; split; assumption);
+ clear id
+ | id: ?X1 -> ?X2|- _ =>
+ $t_flatten_contravariant_disj
+ (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2|-" and "?B->?X2|-" *)
+ | |- ?X1 => $t_is_conj; split
+ | |- (Coq.Init.Logic.iff _ _) => split
end;
$t_not_dep_intros) >>
@@ -153,7 +223,7 @@ let rec tauto_intuit t_reduce solver ist =
[ exact id
| generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id;
solve [ $t_tauto_intuit ]]]
- | |- (?X1 _ _) =>
+ | |- ?X1 =>
$t_is_disj; solve [left;$t_tauto_intuit | right;$t_tauto_intuit]
end
||
@@ -164,13 +234,9 @@ let rec tauto_intuit t_reduce solver ist =
||
$t_solver
) >>
-
+
let reduction_not_iff _ist =
- <:tactic<repeat
- match goal with
- | |- _ => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff
- | H:_ |- _ => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in H
- end >>
+ <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >>
let t_reduction_not_iff = tacticIn reduction_not_iff
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-05 01:12:56 +0000