summaryrefslogtreecommitdiff
path: root/plugins/ssr/ssripats.ml
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/ssr/ssripats.ml')
-rw-r--r--plugins/ssr/ssripats.ml85
1 files changed, 51 insertions, 34 deletions
diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml
index 35036b6c..37dd00a7 100644
--- a/plugins/ssr/ssripats.ml
+++ b/plugins/ssr/ssripats.ml
@@ -12,6 +12,7 @@ open Ssrmatching_plugin
open Util
open Names
+open Constr
open Proofview
open Proofview.Notations
@@ -90,11 +91,11 @@ open State
(** Warning: unlike [nb_deps_assums], it does not perform reduction *)
let rec nb_assums cur env sigma t =
match EConstr.kind sigma t with
- | Term.Prod(name,ty,body) ->
+ | Prod(name,ty,body) ->
nb_assums (cur+1) env sigma body
- | Term.LetIn(name,ty,t1,t2) ->
+ | LetIn(name,ty,t1,t2) ->
nb_assums (cur+1) env sigma t2
- | Term.Cast(t,_,_) ->
+ | Cast(t,_,_) ->
nb_assums cur env sigma t
| _ -> cur
let nb_assums = nb_assums 0
@@ -118,13 +119,10 @@ let intro_end =
Ssrcommon.tcl0G (isCLR_CONSUME)
(** [=> _] *****************************************************************)
-let intro_clear ids future_ipats =
+let intro_clear ids =
Goal.enter begin fun gl ->
let _, clear_ids, ren =
List.fold_left (fun (used_ids, clear_ids, ren) id ->
- if not(Ssrcommon.is_name_in_ipats id future_ipats) then begin
- used_ids, id :: clear_ids, ren
- end else
let new_id = Ssrcommon.mk_anon_id (Id.to_string id) used_ids in
(new_id :: used_ids, new_id :: clear_ids, (id, new_id) :: ren))
(Tacmach.New.pf_ids_of_hyps gl, [], []) ids
@@ -212,22 +210,25 @@ let tclLOG p t =
tclUNIT ()
end
-let rec ipat_tac1 future_ipats ipat : unit tactic =
+let rec ipat_tac1 ipat : unit tactic =
match ipat with
- | IPatView l ->
- Ssrview.tclIPAT_VIEWS ~views:l
- ~conclusion:(fun ~to_clear:clr -> intro_clear clr future_ipats)
- | IPatDispatch ipatss ->
- tclEXTEND (List.map (ipat_tac future_ipats) ipatss) (tclUNIT ()) []
+ | IPatView (clear_if_id,l) ->
+ Ssrview.tclIPAT_VIEWS ~views:l ~clear_if_id
+ ~conclusion:(fun ~to_clear:clr -> intro_clear clr)
+
+ | IPatDispatch(true,[[]]) ->
+ tclUNIT ()
+ | IPatDispatch(_,ipatss) ->
+ tclDISPATCH (List.map ipat_tac ipatss)
| IPatId id -> Ssrcommon.tclINTRO_ID id
| IPatCase ipatss ->
- tclIORPAT (Ssrcommon.tclWITHTOP tac_case) future_ipats ipatss
+ tclIORPAT (Ssrcommon.tclWITHTOP tac_case) ipatss
| IPatInj ipatss ->
tclIORPAT (Ssrcommon.tclWITHTOP
(fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t)))
- future_ipats ipatss
+ ipatss
| IPatAnon Drop -> intro_drop
| IPatAnon One -> Ssrcommon.tclINTRO_ANON
@@ -238,7 +239,7 @@ let rec ipat_tac1 future_ipats ipat : unit tactic =
| IPatClear ids ->
tacCHECK_HYPS_EXIST ids <*>
- intro_clear (List.map Ssrcommon.hyp_id ids) future_ipats
+ intro_clear (List.map Ssrcommon.hyp_id ids)
| IPatSimpl (Simpl n) ->
V82.tactic ~nf_evars:false (Ssrequality.simpltac (Simpl n))
@@ -255,17 +256,17 @@ let rec ipat_tac1 future_ipats ipat : unit tactic =
| IPatTac t -> t
-and ipat_tac future_ipats pl : unit tactic =
+and ipat_tac pl : unit tactic =
match pl with
| [] -> tclUNIT ()
| pat :: pl ->
- Ssrcommon.tcl0G (tclLOG pat (ipat_tac1 (pl @ future_ipats))) <*>
+ Ssrcommon.tcl0G (tclLOG pat ipat_tac1) <*>
isTICK pat <*>
- ipat_tac future_ipats pl
+ ipat_tac pl
-and tclIORPAT tac future_ipats = function
+and tclIORPAT tac = function
| [[]] -> tac
- | p -> Tacticals.New.tclTHENS tac (List.map (ipat_tac future_ipats) p)
+ | p -> Tacticals.New.tclTHENS tac (List.map ipat_tac p)
let split_at_first_case ipats =
let rec loop acc = function
@@ -276,17 +277,32 @@ let split_at_first_case ipats =
loop [] ipats
let ssr_exception is_on = function
- | Some (IPatCase l) when is_on -> Some (IPatDispatch l)
+ | Some (IPatCase l) when is_on -> Some (IPatDispatch(true, l))
| x -> x
let option_to_list = function None -> [] | Some x -> [x]
+(* Simple pass doing {x}/v -> /v{x} *)
+let elaborate_ipats l =
+ let rec elab = function
+ | [] -> []
+ | (IPatClear _ as p1) :: (IPatView _ as p2) :: rest -> p2 :: p1 :: elab rest
+ | IPatDispatch(s,p) :: rest -> IPatDispatch (s,List.map elab p) :: elab rest
+ | IPatCase p :: rest -> IPatCase (List.map elab p) :: elab rest
+ | IPatInj p :: rest -> IPatInj (List.map elab p) :: elab rest
+ | (IPatTac _ | IPatId _ | IPatSimpl _ | IPatClear _ |
+ IPatAnon _ | IPatView _ | IPatNoop | IPatRewrite _ |
+ IPatAbstractVars _) as x :: rest -> x :: elab rest
+ in
+ elab l
+
let main ?eqtac ~first_case_is_dispatch ipats =
+ let ipats = elaborate_ipats ipats in
let ip_before, case, ip_after = split_at_first_case ipats in
let case = ssr_exception first_case_is_dispatch case in
let case = option_to_list case in
let eqtac = option_to_list (Option.map (fun x -> IPatTac x) eqtac) in
- Ssrcommon.tcl0G (ipat_tac [] (ip_before @ case @ eqtac @ ip_after) <*> intro_end)
+ Ssrcommon.tcl0G (ipat_tac (ip_before @ case @ eqtac @ ip_after) <*> intro_end)
end (* }}} *)
@@ -366,8 +382,9 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr =
let ctx, last = EConstr.decompose_prod_assum sigma concl in
let args = match EConstr.kind_of_type sigma last with
| Term.AtomicType (hd, args) ->
- assert(Ssrcommon.is_protect hd env sigma);
- args
+ if Ssrcommon.is_protect hd env sigma then args
+ else Ssrcommon.errorstrm
+ (Pp.str "Too many names in intro pattern")
| _ -> assert false in
let case = args.(Array.length args-1) in
if not(EConstr.Vars.closed0 sigma case)
@@ -419,7 +436,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin
Goal.enter_one begin fun g ->
let pat = Ssrmatching.interp_cpattern sigma0 t None in
let cl0, env, sigma, hyps = Goal.(concl g, env g, sigma g, hyps g) in
- let cl = EConstr.to_constr sigma cl0 in
+ let cl = EConstr.to_constr ~abort_on_undefined_evars:false sigma cl0 in
let (c, ucst), cl =
try Ssrmatching.fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1
with Ssrmatching.NoMatch -> Ssrmatching.redex_of_pattern env pat, cl in
@@ -556,7 +573,7 @@ let rec eqmoveipats eqpat = function
let ssrsmovetac = Goal.enter begin fun g ->
let sigma, concl = Goal.(sigma g, concl g) in
match EConstr.kind sigma concl with
- | Term.Prod _ | Term.LetIn _ -> tclUNIT ()
+ | Prod _ | LetIn _ -> tclUNIT ()
| _ -> Tactics.hnf_in_concl
end
@@ -575,7 +592,7 @@ let ssrmovetac = function
(tacVIEW_THEN_GRAB view ~conclusion) <*>
tclIPAT (IPatClear clr :: ipats)
| _::_ as view, (_, ({ gens = []; clr }, ipats)) ->
- tclIPAT (IPatView view :: IPatClear clr :: ipats)
+ tclIPAT (IPatView (false,view) :: IPatClear clr :: ipats)
| _, (Some pat, (dgens, ipats)) ->
let dgentac = with_dgens dgens eqmovetac in
dgentac <*> tclIPAT (eqmoveipats pat ipats)
@@ -594,8 +611,8 @@ let rec is_Evar_or_CastedMeta sigma x =
let occur_existential_or_casted_meta sigma c =
let rec occrec c = match EConstr.kind sigma c with
- | Term.Evar _ -> raise Not_found
- | Term.Cast (m,_,_) when EConstr.isMeta sigma m -> raise Not_found
+ | Evar _ -> raise Not_found
+ | Cast (m,_,_) when EConstr.isMeta sigma m -> raise Not_found
| _ -> EConstr.iter sigma occrec c
in
try occrec c; false
@@ -624,8 +641,8 @@ let tacFIND_ABSTRACT_PROOF check_lock abstract_n =
Goal.enter_one ~__LOC__ begin fun g ->
let sigma, env = Goal.(sigma g, env g) in
let l = Evd.fold_undefined (fun e ei l ->
- match EConstr.kind sigma (EConstr.of_constr ei.Evd.evar_concl) with
- | Term.App(hd, [|ty; n; lock|])
+ match EConstr.kind sigma ei.Evd.evar_concl with
+ | App(hd, [|ty; n; lock|])
when (not check_lock ||
(occur_existential_or_casted_meta sigma ty &&
is_Evar_or_CastedMeta sigma lock)) &&
@@ -654,8 +671,8 @@ let ssrabstract dgens =
let sigma, env, concl = Goal.(sigma g, env g, concl g) in
let t = args_id.(0) in
match EConstr.kind sigma t with
- | (Term.Evar _ | Term.Meta _) -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id
- | Term.Cast(m,_,_)
+ | (Evar _ | Meta _) -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id
+ | Cast(m,_,_)
when EConstr.isEvar sigma m || EConstr.isMeta sigma m ->
Ssrcommon.tacUNIFY concl t <*> tclUNIT id
| _ ->
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-02 15:23:26 +0000