Quellverzeichnis g_ltac2.mlg
Sprache: unbekannt
|
|
Columbo aufrufen.mlg zum Wurzelverzeichnis wechselnUnknown {[0] [0] [0]}Datei anzeigen (************************************************************************)
(* * The Rocq Prover / The Rocq Development Team *)
(* v * Copyright INRIA, CNRS and contributors *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
DECLARE PLUGIN "rocq-runtime.plugins.ltac2"
{
open Pp
open Util
open Names
open Procq
open Procq.Prim
open Attributes
open Constrexpr
open Tac2expr
open Tac2qexpr
let lk_ident_or_anti =
Procq.Lookahead.(lk_ident <+> (lk_kw "$" >> lk_ident >> check_no_space))
(* lookahead for (x:=t), (?x:=t) and (1:=t) *)
let test_lpar_idnum_coloneq =
let open Procq.Lookahead in
to_entry "test_lpar_idnum_coloneq" begin
lk_kw "(" >> (lk_ident_or_anti <+> lk_nat) >> lk_kw ":="
end
(* lookahead for (x:t), (?x:t) *)
let test_lpar_id_colon =
let open Procq.Lookahead in
to_entry "test_lpar_id_colon" begin
lk_kw "(" >> lk_ident_or_anti >> lk_kw ":"
end
(* Hack to recognize "(x := t)" and "($x := t)" *)
let test_lpar_id_coloneq =
let open Procq.Lookahead in
to_entry "test_lpar_id_coloneq" begin
lk_kw "(" >> lk_ident_or_anti >> lk_kw ":="
end
(* Hack to recognize "(x)" *)
let test_lpar_id_rpar =
let open Procq.Lookahead in
to_entry "test_lpar_id_rpar" begin
lk_kw "(" >> lk_ident >> lk_kw ")"
end
let test_ampersand_ident =
let open Procq.Lookahead in
to_entry "test_ampersand_ident" begin
lk_kw "&" >> lk_ident >> check_no_space
end
let test_dollar_ident =
let open Procq.Lookahead in
to_entry "test_dollar_ident" begin
lk_kw "$" >> lk_ident >> check_no_space
end
let test_dollar_ident_colon_ident =
let open Procq.Lookahead in
to_entry "test_dollar_ident_colon_ident" begin
lk_kw "$" >> lk_ident >> lk_kw ":" >> lk_ident >> check_no_space
end
let test_ltac1_env =
let open Procq.Lookahead in
to_entry "test_ltac1_env" begin
lk_ident_list >> lk_kw "|-"
end
let test_qualid_with_or_lpar_or_rbrac =
let open Procq.Lookahead in
to_entry "test_qualid_with_or_lpar_or_rbrac" begin
(lk_qualid >> lk_kw "with") <+> lk_kw "(" <+> lk_kw "{"
end
let test_array_opening =
let open Procq.Lookahead in
to_entry "test_array_opening" begin
lk_kw "[" >> lk_kw "|" >> check_no_space
end
let test_array_closing =
let open Procq.Lookahead in
to_entry "test_array_closing" begin
lk_kw "|" >> lk_kw "]" >> check_no_space
end
let test_leftsquarebracket_equal =
let open Procq.Lookahead in
to_entry "test_leftsquarebracket_equal" begin
lk_kw "[" >> lk_kw "=" >> check_no_space
end
let ltac2_expr = Tac2entries.Pltac.ltac2_expr
let _ltac2_expr = ltac2_expr
let ltac2_type = Entry.make "ltac2_type"
let tac2def_val = Entry.make "tac2def_val"
let tac2def_typ = Entry.make "tac2def_typ"
let tac2def_ext = Entry.make "tac2def_ext"
let tac2def_syn = Entry.make "tac2def_syn"
let tac2def_mut = Entry.make "tac2def_mut"
let tac2mode = Entry.make "ltac2_command"
let ltac2_atom = Entry.make "ltac2_atom"
let tac2expr_in_env = Tac2entries.Pltac.tac2expr_in_env
let quoted_attributes = G_vernac.quoted_attributes
let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x)
let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c
let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c
let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c
let pattern_of_qualid qid =
if Tac2env.is_constructor qid then CAst.make ?loc:qid.CAst.loc @@ CPatRef (RelId qid, [])
else
let open Libnames in
if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ CPatVar (Name (qualid_basename qid))
else
CErrors.user_err ?loc:qid.CAst.loc (Pp.str "Syntax error")
let opt_fun ?loc args ty e =
let e = match ty with
| None -> e
| Some ty -> CAst.make ?loc:e.CAst.loc (CTacCnv (e, ty))
in
match args with
| [] -> e
| _ :: _ -> CAst.make ?loc (CTacFun (args, e))
}
GRAMMAR EXTEND Gram
GLOBAL: ltac2_expr ltac2_type tac2def_val tac2def_typ tac2def_ext tac2def_syn
tac2def_mut tac2expr_in_env ltac2_atom;
tac2pat:
[ "1" LEFTA
[ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> {
if Tac2env.is_constructor qid then
CAst.make ~loc @@ CPatRef (RelId qid, pl)
else
CErrors.user_err ~loc (Pp.str "Syntax error") }
| qid = Prim.qualid -> { pattern_of_qualid qid }
(* | "["; "]" -> { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) } *)
| p1 = tac2pat; "::"; p2 = tac2pat ->
{ CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2])}
| p = tac2pat; "|"; pl = LIST1 tac2pat SEP "|" ->
{ let pl = p :: pl in
CAst.make ~loc @@ CPatOr pl }
| p = tac2pat; "as"; id = identref -> { CAst.make ~loc @@ CPatAs (p,id) }
]
| "0"
[ "_" -> { CAst.make ~loc @@ CPatVar Anonymous }
| "()" -> { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) }
| n = Prim.integer -> { CAst.make ~loc @@ CPatAtm (AtmInt n) }
| s = Prim.string -> { CAst.make ~loc @@ CPatAtm (AtmStr s) }
| qid = Prim.qualid -> { pattern_of_qualid qid }
| "("; p = atomic_tac2pat; ")" -> { p }
| "{"; a = tac2rec_fieldpats; "}" -> { CAst.make ~loc @@ CPatRecord a }
| "["; pats = LIST0 tac2pat SEP ";"; "]" ->
{
let nil = CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) in
let cons hd tl = CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [hd;tl]) in
List.fold_right cons pats nil
}
] ]
;
atomic_tac2pat:
[ [ ->
{ CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) }
| p = tac2pat; ":"; t = ltac2_type ->
{ CAst.make ~loc @@ CPatCnv (p, t) }
| p = tac2pat; ","; pl = LIST0 tac2pat SEP "," ->
{ let pl = p :: pl in
CAst.make ~loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) }
| p = tac2pat -> { p }
] ]
;
ltac2_expr:
[ "6" RIGHTA
[ e1 = SELF; ";"; e2 = SELF -> { CAst.make ~loc @@ CTacSeq (e1, e2) } ]
| "5"
[ "fun"; it = LIST1 input_fun; ty = type_cast; "=>"; body = ltac2_expr LEVEL "6" ->
{ opt_fun ~loc it ty body }
| "let"; isrec = rec_flag;
lc = LIST1 let_clause SEP "with"; "in";
e = ltac2_expr LEVEL "6" ->
{ CAst.make ~loc @@ CTacLet (isrec, lc, e) }
| "match"; e = ltac2_expr LEVEL "5"; "with"; bl = branches; "end" ->
{ CAst.make ~loc @@ CTacCse (e, bl) }
| "if"; e = ltac2_expr LEVEL "5"; "then"; e1 = ltac2_expr LEVEL "5"; "else"; e2 = ltac2_expr LEVEL "5" ->
{ CAst.make ~loc @@ CTacIft (e, e1, e2) }
]
| "4" LEFTA [ ]
| "3" [ e0 = SELF; ","; el = LIST1 NEXT SEP "," ->
{ let el = e0 :: el in
CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ]
| "2" RIGHTA
[ e1 = ltac2_expr; "::"; e2 = ltac2_expr ->
{ CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) }
]
| "1" LEFTA
[ e = ltac2_expr; el = LIST1 ltac2_expr LEVEL "0" ->
{ CAst.make ~loc @@ CTacApp (e, el) }
| e = SELF; ".("; qid = Prim.qualid; ")" ->
{ CAst.make ~loc @@ CTacPrj (e, RelId qid) }
| e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = ltac2_expr LEVEL "5" ->
{ CAst.make ~loc @@ CTacSet (e, RelId qid, r) } ]
| "0"
[ "("; a = SELF; ")" -> { a }
| "("; a = SELF; ":"; t = ltac2_type; ")" ->
{ CAst.make ~loc @@ CTacCnv (a, t) }
| "()" ->
{ CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) }
| "("; ")" ->
{ CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) }
| a = array_literal -> { a }
| a = list_literal -> { a }
| "{"; test_qualid_with_or_lpar_or_rbrac; e = ltac2_expr LEVEL "0"; "with"; a = tac2rec_fieldexprs; "}" ->
{ CAst.make ~loc @@ CTacRec (Some e, a) }
| "{"; a = tac2rec_fieldexprs; "}" ->
{ CAst.make ~loc @@ CTacRec (None, a) }
| a = ltac2_atom -> { a } ]
]
;
array_literal:
[ [ test_array_opening; "["; "|"; a = LIST0 ltac2_expr LEVEL "5" SEP ";"; test_array_closing; "|"; "]" ->
{ Tac2quote.array_literal ~loc a } ] ]
;
list_literal:
[ [ "["; a = LIST0 ltac2_expr LEVEL "5" SEP ";"; "]" ->
{ Tac2quote.of_list ~loc (fun x -> x) a } ] ]
;
branches:
[ [ -> { [] }
| "|"; bl = LIST1 branch SEP "|" -> { bl }
| bl = LIST1 branch SEP "|" -> { bl } ]
]
;
branch:
[ [ pat = atomic_tac2pat; "=>"; e = ltac2_expr LEVEL "6" -> { (pat, e) } ] ]
;
rec_flag:
[ [ IDENT "rec" -> { true }
| -> { false } ] ]
;
mut_flag:
[ [ IDENT "mutable" -> { true }
| -> { false } ] ]
;
ltac2_typevar:
[ [ "'"; id = Prim.ident -> { id } ] ]
;
ltac2_atom:
[ [ n = Prim.integer -> { CAst.make ~loc @@ CTacAtm (AtmInt n) }
| s = Prim.string -> { CAst.make ~loc @@ CTacAtm (AtmStr s) }
| qid = Prim.qualid ->
{ if Tac2env.is_constructor qid then
CAst.make ~loc @@ CTacCst (RelId qid)
else
CAst.make ~loc @@ CTacRef (RelId qid) }
| "@"; id = Prim.ident -> { Tac2quote.of_ident (CAst.make ~loc id) }
| "&"; id = identref -> { Tac2quote.of_hyp ~loc id }
| "'"; c = Constr.constr -> { inj_open_constr loc c }
| IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c }
| IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c }
| IDENT "preterm"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_preterm c }
| IDENT "ident"; ":"; "("; c = identref; ")" -> { Tac2quote.of_ident c }
| IDENT "pat"; ":"; "("; c = Constr.cpattern; ")" -> { inj_pattern loc c }
| IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c }
] ]
;
tac2expr_in_env :
[ [ test_ltac1_env; ids = LIST0 identref; "|-"; e = ltac2_expr ->
{ let check { CAst.v = id; CAst.loc = loc } =
if Tac2env.is_constructor (Libnames.qualid_of_ident ?loc id) then
CErrors.user_err ?loc Pp.(str "Invalid bound Ltac2 identifier " ++ Id.print id)
in
let () = List.iter check ids in
(ids, e)
}
| tac = ltac2_expr -> { [], tac }
] ]
;
type_cast:
[ [ -> { None }
| ":"; ty = ltac2_type -> { Some ty }
] ]
;
let_clause:
[ [ binder = let_binder; ty = type_cast; ":="; te = ltac2_expr ->
{ let (pat, fn) = binder in
let te = opt_fun ~loc fn ty te in
(pat, te) }
] ]
;
let_binder:
[ [ pats = LIST1 input_fun ->
{ match pats with
| [{CAst.v=CPatVar _} as pat] -> (pat, [])
| ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, args)
| [pat] -> (pat, [])
| _ -> CErrors.user_err ~loc (str "Invalid pattern") }
] ]
;
ltac2_type:
[ "5" RIGHTA
[ t1 = ltac2_type; "->"; t2 = ltac2_type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ]
| "2"
[ t = ltac2_type; "*"; tl = LIST1 ltac2_type LEVEL "1" SEP "*" ->
{ let tl = t :: tl in
CAst.make ~loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) } ]
| "1" LEFTA
[ t = SELF; qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, [t]) } ]
| "0"
[ "("; p = LIST1 ltac2_type LEVEL "5" SEP ","; ")"; qid = OPT Prim.qualid ->
{ match p, qid with
| [t], None -> t
| _, None -> CErrors.user_err ~loc (Pp.str "Syntax error")
| ts, Some qid -> CAst.make ~loc @@ CTypRef (RelId qid, p)
}
| id = ltac2_typevar -> { CAst.make ~loc @@ CTypVar (Name id) }
| "_" -> { CAst.make ~loc @@ CTypVar Anonymous }
| qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, []) }
]
];
binder:
[ [ "_" -> { CAst.make ~loc Anonymous }
| l = Prim.ident -> { CAst.make ~loc (Name l) } ] ]
;
input_fun:
[ [ b = tac2pat LEVEL "0" -> { b } ] ]
;
tac2def_body:
[ [ name = binder; it = LIST0 input_fun; ty = type_cast; ":="; e = ltac2_expr ->
{ (name, opt_fun ~loc it ty e) }
] ]
;
tac2def_val:
[ [ mut = mut_flag; isrec = rec_flag; l = LIST1 tac2def_body SEP "with" ->
{ StrVal (mut, isrec, l) }
] ]
;
tac2def_mut:
[ [ "Set"; qid = Prim.qualid; old = OPT [ "as"; id = identref -> { id } ]; ":="; e = ltac2_expr -> { StrMut (qid, old, e) } ] ]
;
tac2typ_knd:
[ [ t = ltac2_type -> { CTydDef (Some t) }
| "["; ".."; "]" -> { CTydOpn }
| "["; t = tac2alg_constructors; "]" -> { CTydAlg t }
| "{"; t = tac2rec_fields; "}"-> { CTydRec t } ] ]
;
tac2alg_constructors:
[ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> { cs }
| cs = LIST0 tac2alg_constructor SEP "|" -> { cs } ] ]
;
tac2alg_constructor:
[ [ atts = quoted_attributes; c = Prim.ident -> { (atts, c, []) }
| atts = quoted_attributes; c = Prim.ident; "("; args = LIST0 ltac2_type SEP ","; ")" ->
{ (atts, c, args) } ] ]
;
tac2rec_fields:
[ [ f = tac2rec_field; ";"; l = tac2rec_fields -> { f :: l }
| f = tac2rec_field; ";" -> { [f] }
| f = tac2rec_field -> { [f] }
| -> { [] } ] ]
;
tac2rec_field:
[ [ mut = mut_flag; id = Prim.ident; ":"; t = ltac2_type -> { (id, mut, t) } ] ]
;
tac2rec_fieldexprs:
[ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> { f :: l }
| f = tac2rec_fieldexpr; ";" -> { [f] }
| f = tac2rec_fieldexpr-> { [f] }
| -> { [] } ] ]
;
tac2rec_fieldexpr:
[ [ qid = Prim.qualid; e = OPT [ ":="; e = ltac2_expr LEVEL "1" -> { e } ] ->
{ let e = match e with
| Some e -> e
| None ->
(* punning: [Foo.bar] becomes [Foo.bar := bar] *)
let id = Libnames.qualid_basename qid in
CAst.make ~loc @@ CTacRef (RelId (Libnames.qualid_of_ident ~loc id))
in
RelId qid, e }
] ]
;
tac2rec_fieldpats:
[ [ f = tac2rec_fieldpat; ";"; l = tac2rec_fieldpats -> { f :: l }
| f = tac2rec_fieldpat; ";" -> { [f] }
| f = tac2rec_fieldpat-> { [f] }
| -> { [] } ] ]
;
tac2rec_fieldpat:
[ [ qid = Prim.qualid; e = OPT [ ":="; e = tac2pat LEVEL "1" -> { e } ] ->
{ let e = match e with
| Some e -> e
| None ->
(* punning: [Foo.bar] becomes [Foo.bar := bar] *)
let id = Libnames.qualid_basename qid in
CAst.make ~loc @@ CPatVar (Name id)
in
RelId qid, e }
] ]
;
tac2typ_prm:
[ [ -> { [] }
| id = ltac2_typevar -> { [CAst.make ~loc id] }
| "("; ids = LIST1 [ id = ltac2_typevar -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids }
] ]
;
tac2typ_def:
[ [ prm = tac2typ_prm; id = Prim.qualid; b = tac2type_body -> { let (r, e) = b in (id, r, (prm, e)) } ] ]
;
tac2type_body:
[ [ -> { false, CTydDef None }
| ":="; e = tac2typ_knd -> { false, e }
| "::="; e = tac2typ_knd -> { true, e }
] ]
;
tac2def_typ:
[ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" ->
{ StrTyp (isrec, l) }
] ]
;
tac2def_ext:
[ [ "@"; IDENT "external"; id = identref; ":"; t = ltac2_type LEVEL "5"; ":=";
plugin = Prim.string; name = Prim.string ->
{ let ml = { mltac_plugin = plugin; mltac_tactic = name } in
StrPrm (id, t, ml) }
] ]
;
syn_node:
[ [ "_" -> { CAst.make ~loc None }
| id = Prim.ident -> { CAst.make ~loc (Some id) }
] ]
;
ltac2_syntax_class:
[ [ s = Prim.string -> { SexprStr (CAst.make ~loc s) }
| n = Prim.integer -> { SexprInt (CAst.make ~loc n) }
| id = syn_node -> { SexprRec (loc, id, []) }
| id = syn_node; "("; tok = LIST1 ltac2_syntax_class SEP "," ; ")" ->
{ SexprRec (loc, id, tok) }
] ]
;
syn_level:
[ [ -> { None }
| ":"; n = Prim.natural -> { Some n }
] ]
;
tac2def_syn:
[ [ toks = LIST1 ltac2_syntax_class; n = syn_level; ":=";
e = ltac2_expr ->
{ (toks, n, e) }
] ]
;
globref:
[ [ "&"; id = Prim.ident -> { CAst.make ~loc (QHypothesis id) }
| qid = Prim.qualid -> { CAst.make ~loc @@ QReference qid }
] ]
;
END
(* Quotation entries used by notations *)
{
open Tac2entries.Pltac
}
GRAMMAR EXTEND Gram
GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause
q_conversion q_orient q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag
q_destruction_arg q_reference q_with_bindings q_constr_matching
q_goal_matching q_hintdb q_move_location q_pose q_assert;
anti:
[ [ "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } ] ]
;
ident_or_anti:
[ [ id = identref -> { QExpr id }
| "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) }
] ]
;
lnatural:
[ [ n = Prim.natural -> { CAst.make ~loc n } ] ]
;
q_ident:
[ [ id = ident_or_anti -> { id } ] ]
;
qhyp:
[ [ x = anti -> { x }
| n = lnatural -> { QExpr (CAst.make ~loc @@ QAnonHyp n) }
| id = identref -> { QExpr (CAst.make ~loc @@ QNamedHyp id) }
] ]
;
simple_binding:
[ [ "("; h = qhyp; ":="; c = Constr.lconstr; ")" ->
{ CAst.make ~loc (h, c) }
] ]
;
bindings:
[ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding ->
{ CAst.make ~loc @@ QExplicitBindings bl }
| bl = LIST1 Constr.constr ->
{ CAst.make ~loc @@ QImplicitBindings bl }
] ]
;
q_bindings:
[ [ bl = bindings -> { bl } ] ]
;
q_with_bindings:
[ [ bl = with_bindings -> { bl } ] ]
;
intropatterns:
[ [ l = LIST0 nonsimple_intropattern -> { CAst.make ~loc l } ] ]
;
(* ne_intropatterns: *)
(* [ [ l = LIST1 nonsimple_intropattern -> l ]] *)
(* ; *)
or_and_intropattern:
[ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> { CAst.make ~loc @@ QIntroOrPattern tc }
| "()" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc []) }
| "("; si = simple_intropattern; ")" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc [si]) }
| "("; si = simple_intropattern; ",";
tc = LIST1 simple_intropattern SEP "," ; ")" ->
{ CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc (si::tc)) }
| "("; si = simple_intropattern; "&";
tc = LIST1 simple_intropattern SEP "&" ; ")" ->
(* (A & B & C) is translated into (A,(B,C)) *)
{ let rec pairify = function
| ([]|[_]|[_;_]) as l -> CAst.make ~loc l
| t::q ->
let q =
CAst.make ~loc @@
QIntroAction (CAst.make ~loc @@
QIntroOrAndPattern (CAst.make ~loc @@
QIntroAndPattern (pairify q)))
in
CAst.make ~loc [t; q]
in CAst.make ~loc @@ QIntroAndPattern (pairify (si::tc)) } ] ]
;
equality_intropattern:
[ [ "->" -> { CAst.make ~loc @@ QIntroRewrite true }
| "<-" -> { CAst.make ~loc @@ QIntroRewrite false }
| test_leftsquarebracket_equal; "["; "="; tc = intropatterns; "]" -> { CAst.make ~loc @@ QIntroInjection tc } ] ]
;
naming_intropattern:
[ [ LEFTQMARK; id = identref ->
{ CAst.make ~loc @@ QIntroFresh (QExpr id) }
| "?$"; id = identref ->
{ CAst.make ~loc @@ QIntroFresh (QAnti id) }
| "?" ->
{ CAst.make ~loc @@ QIntroAnonymous }
| id = ident_or_anti ->
{ CAst.make ~loc @@ QIntroIdentifier id }
] ]
;
nonsimple_intropattern:
[ [ l = simple_intropattern -> { l }
| "*" -> { CAst.make ~loc @@ QIntroForthcoming true }
| "**" -> { CAst.make ~loc @@ QIntroForthcoming false } ] ]
;
simple_intropattern:
[ [ pat = simple_intropattern_closed;
l = LIST0 [ "%"; c = Constr.term LEVEL "0" -> { c } ] ->
{ let mk c pat =
CAst.make ~loc @@ QIntroAction
(CAst.make ~loc @@ QIntroApplyOn (c, pat))
in
List.fold_right mk l pat
}
] ]
;
simple_intropattern_closed:
[ [ pat = or_and_intropattern ->
{ CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroOrAndPattern pat) }
| pat = equality_intropattern ->
{ CAst.make ~loc @@ QIntroAction pat }
| "_" ->
{ CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroWildcard) }
| pat = naming_intropattern ->
{ CAst.make ~loc @@ QIntroNaming pat }
] ]
;
q_intropatterns:
[ [ ipat = intropatterns -> { ipat } ] ]
;
q_intropattern:
[ [ ipat = simple_intropattern -> { ipat } ] ]
;
nat_or_anti:
[ [ n = lnatural -> { QExpr n }
| "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) }
] ]
;
eqn_ipat:
[ [ IDENT "eqn"; ":"; pat = naming_intropattern -> { Some pat }
| -> { None }
] ]
;
with_bindings:
[ [ "with"; bl = bindings -> { bl } | -> { CAst.make ~loc @@ QNoBindings } ] ]
;
constr_with_bindings:
[ [ c = Constr.constr; l = with_bindings -> { CAst.make ~loc @@ (c, l) } ] ]
;
destruction_arg:
[ [ n = lnatural -> { CAst.make ~loc @@ QElimOnAnonHyp n }
| id = identref -> { CAst.make ~loc @@ QElimOnIdent id }
| c = constr_with_bindings -> { CAst.make ~loc @@ QElimOnConstr c }
] ]
;
q_destruction_arg:
[ [ arg = destruction_arg -> { arg } ] ]
;
as_or_and_ipat:
[ [ "as"; ipat = or_and_intropattern -> { Some ipat }
| -> { None }
] ]
;
occs_nums:
[ [ nl = LIST1 nat_or_anti -> { CAst.make ~loc @@ QOnlyOccurrences nl }
| "-"; n = nat_or_anti; nl = LIST0 nat_or_anti ->
{ CAst.make ~loc @@ QAllOccurrencesBut (n::nl) }
] ]
;
occs:
[ [ "at"; occs = occs_nums -> { occs } | -> { CAst.make ~loc QAllOccurrences } ] ]
;
hypident:
[ [ id = ident_or_anti ->
{ id,Locus.InHyp }
| "("; IDENT "type"; IDENT "of"; id = ident_or_anti; ")" ->
{ id,Locus.InHypTypeOnly }
| "("; IDENT "value"; IDENT "of"; id = ident_or_anti; ")" ->
{ id,Locus.InHypValueOnly }
] ]
;
hypident_occ:
[ [ h=hypident; occs=occs -> { let (id,l) = h in ((occs,id),l) } ] ]
;
in_clause:
[ [ "*"; occs=occs ->
{ { q_onhyps = None; q_concl_occs = occs } }
| "*"; "|-"; occs = concl_occ ->
{ { q_onhyps = None; q_concl_occs = occs } }
| hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ ->
{ { q_onhyps = Some hl; q_concl_occs = occs } }
| hl = LIST0 hypident_occ SEP "," ->
{ { q_onhyps = Some hl; q_concl_occs = CAst.make ~loc QNoOccurrences } }
] ]
;
clause:
[ [ "in"; cl = in_clause -> { CAst.make ~loc @@ cl }
| "at"; occs = occs_nums ->
{ CAst.make ~loc @@ { q_onhyps = Some []; q_concl_occs = occs } }
] ]
;
q_clause:
[ [ cl = clause -> { cl } ] ]
;
concl_occ:
[ [ "*"; occs = occs -> { occs }
| -> { CAst.make ~loc QNoOccurrences }
] ]
;
induction_clause:
[ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat;
cl = OPT clause ->
{ CAst.make ~loc @@ {
indcl_arg = c;
indcl_eqn = eq;
indcl_as = pat;
indcl_in = cl;
} }
] ]
;
q_induction_clause:
[ [ cl = induction_clause -> { cl } ] ]
;
conversion:
[ [ c = Constr.constr ->
{ CAst.make ~loc @@ QConvert c }
| c1 = Constr.constr; "with"; c2 = Constr.constr ->
{ CAst.make ~loc @@ QConvertWith (c1, c2) }
] ]
;
q_conversion:
[ [ c = conversion -> { c } ] ]
;
q_orient:
[ [ "->" -> { CAst.make ~loc (Some true) }
| "<-" -> { CAst.make ~loc (Some false) }
| -> { CAst.make ~loc None }
]]
;
rewriter:
[ [ "!"; c = constr_with_bindings ->
{ (CAst.make ~loc @@ QRepeatPlus,c) }
| [ "?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings ->
{ (CAst.make ~loc @@ QRepeatStar,c) }
| n = lnatural; "!"; c = constr_with_bindings ->
{ (CAst.make ~loc @@ QPrecisely n,c) }
| n = lnatural; ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings ->
{ (CAst.make ~loc @@ QUpTo n,c) }
| n = lnatural; c = constr_with_bindings ->
{ (CAst.make ~loc @@ QPrecisely n,c) }
| c = constr_with_bindings ->
{ (CAst.make ~loc @@ QPrecisely (CAst.make 1), c) }
] ]
;
oriented_rewriter:
[ [ b = q_orient; r = rewriter ->
{ let (m, c) = r in
CAst.make ~loc @@ {
rew_orient = b;
rew_repeat = m;
rew_equatn = c;
} }
] ]
;
q_rewriting:
[ [ r = oriented_rewriter -> { r } ] ]
;
tactic_then_last:
[ [ "|"; lta = LIST0 (OPT ltac2_expr LEVEL "6") SEP "|" -> { lta }
| -> { [] }
] ]
;
for_each_goal:
[ [ ta = ltac2_expr; "|"; tg = for_each_goal -> { let (first,last) = tg in (Some ta :: first, last) }
| ta = ltac2_expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) }
| ".."; l = tactic_then_last -> { ([], Some (None, l)) }
| ta = ltac2_expr -> { ([Some ta], None) }
| "|"; tg = for_each_goal -> { let (first,last) = tg in (None :: first, last) }
| -> { ([None], None) }
] ]
;
q_dispatch:
[ [ d = for_each_goal -> { CAst.make ~loc d } ] ]
;
q_occurrences:
[ [ occs = occs -> { occs } ] ]
;
ltac2_red_flag:
[ [ IDENT "beta" -> { CAst.make ~loc @@ QBeta }
| IDENT "iota" -> { CAst.make ~loc @@ QIota }
| IDENT "match" -> { CAst.make ~loc @@ QMatch }
| IDENT "fix" -> { CAst.make ~loc @@ QFix }
| IDENT "cofix" -> { CAst.make ~loc @@ QCofix }
| IDENT "zeta" -> { CAst.make ~loc @@ QZeta }
| IDENT "delta"; d = delta_flag -> { d }
| IDENT "head" -> { CAst.make ~loc @@ QHead }
] ]
;
refglobal:
[ [ "&"; id = Prim.ident -> { QExpr (CAst.make ~loc @@ QHypothesis id) }
| qid = Prim.qualid -> { QExpr (CAst.make ~loc @@ QReference qid) }
| "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) }
] ]
;
q_reference:
[ [ r = refglobal -> { r } ] ]
;
refglobals:
[ [ gl = LIST1 refglobal -> { CAst.make ~loc gl } ] ]
;
delta_flag:
[ [ "-"; "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QDeltaBut idl }
| "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QConst idl }
| -> { CAst.make ~loc @@ QDeltaBut (CAst.make ~loc []) }
] ]
;
strategy_flag:
[ [ s = LIST1 ltac2_red_flag -> { CAst.make ~loc s }
| d = delta_flag ->
{ CAst.make ~loc
[CAst.make ~loc QBeta; CAst.make ~loc QIota; CAst.make ~loc QZeta; d] }
] ]
;
q_strategy_flag:
[ [ flag = strategy_flag -> { flag } ] ]
;
hintdb:
[ [ "*" -> { CAst.make ~loc @@ QHintAll }
| l = LIST1 ident_or_anti -> { CAst.make ~loc @@ QHintDbs l }
] ]
;
q_hintdb:
[ [ db = hintdb -> { db } ] ]
;
match_pattern:
[ [ IDENT "context"; id = OPT Prim.ident;
"["; pat = Constr.cpattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) }
| pat = Constr.cpattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ]
;
match_rule:
[ [ mp = match_pattern; "=>"; tac = ltac2_expr ->
{ CAst.make ~loc @@ (mp, tac) }
] ]
;
match_list:
[ [ mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl }
| "|"; mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ]
;
q_constr_matching:
[ [ m = match_list -> { m } ] ]
;
gmatch_hyp_pattern:
[ [ na = Prim.name; ":"; pat = match_pattern -> { (na, None, pat) }
| na = Prim.name; ":="; "["; bod = match_pattern; "]"; ":"; pat = match_pattern ->
{ (na, Some bod, pat) }
| na = Prim.name; ":="; bod = match_pattern ->
{ let bod, ty = match bod.CAst.v with
| QConstrMatchPattern { CAst.v = CCast (t, Some DEFAULTcast, ty) } ->
let t = CAst.make ?loc:t.loc @@ QConstrMatchPattern t in
let ty = CAst.make ?loc:ty.loc @@ QConstrMatchPattern ty in
t, ty
| _ ->
let ty = CAst.make @@ QConstrMatchPattern (CAst.make @@ CHole None) in
bod, ty
in
(na, Some bod, ty) }
] ]
;
gmatch_pattern:
[ [ "["; hl = LIST0 gmatch_hyp_pattern SEP ","; "|-"; p = match_pattern; "]" ->
{ CAst.make ~loc @@ {
q_goal_match_concl = p;
q_goal_match_hyps = hl;
} }
] ]
;
gmatch_rule:
[ [ mp = gmatch_pattern; "=>"; tac = ltac2_expr ->
{ CAst.make ~loc @@ (mp, tac) }
] ]
;
goal_match_list:
[ [ mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl }
| "|"; mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ]
;
q_goal_matching:
[ [ m = goal_match_list -> { m } ] ]
;
move_location:
[ [ "at"; IDENT "top" -> { CAst.make ~loc @@ QMoveFirst }
| "at"; IDENT "bottom" -> { CAst.make ~loc @@ QMoveLast }
| IDENT "after"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveAfter id }
| IDENT "before"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveBefore id }
] ]
;
q_move_location:
[ [ mv = move_location -> { mv } ] ]
;
as_name:
[ [ -> { None }
| "as"; id = ident_or_anti -> { Some id }
] ]
;
pose:
[ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" ->
{ CAst.make ~loc (Some id, c) }
| c = Constr.constr; na = as_name -> { CAst.make ~loc (na, c) }
] ]
;
q_pose:
[ [ p = pose -> { p } ] ]
;
as_ipat:
[ [ "as"; ipat = simple_intropattern -> { Some ipat }
| -> { None }
] ]
;
by_tactic:
[ [ "by"; tac = ltac2_expr LEVEL "5" -> { Some tac }
| -> { None }
] ]
;
assertion:
[ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" ->
{ CAst.make ~loc (QAssertValue (id, c)) }
| test_lpar_id_colon; "("; id = ident_or_anti; ":"; c = Constr.lconstr; ")"; tac = by_tactic ->
{ let ipat = CAst.make ~loc @@ QIntroNaming (CAst.make ~loc @@ QIntroIdentifier id) in
CAst.make ~loc (QAssertType (Some ipat, c, tac)) }
| c = Constr.constr; ipat = as_ipat; tac = by_tactic ->
{ CAst.make ~loc (QAssertType (ipat, c, tac)) }
] ]
;
q_assert:
[ [ a = assertion -> { a } ] ]
;
END
(** Extension of constr syntax *)
(*
GRAMMAR EXTEND Gram
Procq.Constr.term: LEVEL "0"
[ [ IDENT "ltac2"; ":"; "("; tac = ltac2_expr; ")" ->
{ let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in
CAst.make ~loc (CGenarg arg) }
| test_ampersand_ident; "&"; id = Prim.ident ->
{ let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in
let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in
CAst.make ~loc (CGenarg arg) }
| test_dollar_ident; "$"; id = Prim.ident ->
{ let id = Loc.tag ~loc id in
let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in
CAst.make ~loc (CGenarg arg) }
] ]
;
END
*)
{
let () =
let open Tok in
let (++) r s = Procq.Rule.next r s in
let rules = [
Procq.(
Production.make
(Rule.stop ++ Symbol.nterm test_dollar_ident ++ Symbol.token (PKEYWORD "$") ++ Symbol.nterm Prim.ident)
begin fun id _ _ loc ->
let id = CAst.make ~loc id in
let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_var_quotation) (None, id) in
CAst.make ~loc (CGenarg arg)
end
);
Procq.(
Production.make
(Rule.stop ++ Symbol.nterm test_dollar_ident_colon_ident ++
Symbol.token (PKEYWORD "$") ++ Symbol.nterm Prim.identref ++
Symbol.token (PKEYWORD ":") ++ Symbol.nterm Prim.identref)
begin fun id _ kind _ _ loc ->
let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_var_quotation) (Some kind, id) in
CAst.make ~loc (CGenarg arg)
end
);
Procq.(
Production.make
(Rule.stop ++ Symbol.nterm test_ampersand_ident ++ Symbol.token (PKEYWORD "&") ++ Symbol.nterm Prim.ident)
begin fun id _ _ loc ->
let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in
let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in
CAst.make ~loc (CGenarg arg)
end
);
Procq.(
Production.make
(Rule.stop ++ Symbol.token (PIDENT (Some "ltac2")) ++ Symbol.token (PKEYWORD ":") ++
Symbol.token (PKEYWORD "(") ++ Symbol.nterm ltac2_expr ++ Symbol.token (PKEYWORD ")"))
begin fun _ tac _ _ _ loc ->
let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in
CAst.make ~loc (CGenarg arg)
end
)
] in
Egramml.grammar_extend ~plugin_uid:("rocq-runtime.plugins.ltac2", "g_ltac2.mlg:adhoc1")
Procq.Constr.term (Procq.Reuse (Some"0", rules))
}
{
let pr_ltac2entry = Tac2print.pr_strexpr
let pr_ltac2expr e = Tac2print.pr_rawexpr_gen E5 ~avoid:Id.Set.empty e
let pr_ltac2def_syn (a,b,c) = Tac2entries.pr_register_notation a b c
}
VERNAC ARGUMENT EXTEND ltac2_entry
PRINTED BY { pr_ltac2entry }
| [ tac2def_val(v) ] -> { v }
| [ tac2def_typ(t) ] -> { t }
| [ tac2def_ext(e) ] -> { e }
| [ tac2def_mut(e) ] -> { e }
END
VERNAC ARGUMENT EXTEND ltac2def_syn
PRINTED BY { pr_ltac2def_syn }
| [ tac2def_syn(e) ] -> { e }
END
VERNAC ARGUMENT EXTEND ltac2_expr
PRINTED BY { pr_ltac2expr }
| [ _ltac2_expr(e) ] -> { e }
END
{
let names_of_strexpr = function
| StrVal(_, _, l) ->
List.concat_map (fun (na, _) -> match na.CAst.v with Anonymous -> [] | Name id -> [id]) l
| StrTyp(_, l) ->
List.map (fun (qid, _, _) -> Libnames.qualid_basename qid) l
| _ -> []
}
VERNAC COMMAND EXTEND VernacDeclareTactic2Definition
| #[ raw_attributes ] [ "Ltac2" ltac2_entry(e) ] => {
VtSideff (names_of_strexpr e, VtLater)
} -> {
Tac2entries.register_struct raw_attributes e
}
| #[ raw_attributes ] [ "Ltac2" "Notation" ltac2def_syn(e) ] => { Vernacextend.(VtSideff ([], VtNow)) } SYNTERP AS synterpv {
let (toks, n, body) = e in
Tac2entries.register_notation raw_attributes toks n body
} ->
{
Tac2entries.register_notation_interpretation synterpv
}
| ![proof_opt_query] [ "Ltac2" "Eval" ltac2_expr(e) ] => { Vernacextend.classify_as_query } -> {
fun ~pstate -> Tac2entries.perform_eval ~pstate e
}
END
{
let _ : Pvernac.proof_mode = Pvernac.register_proof_mode "Ltac2"
(ProofMode {
command_entry = tac2mode;
wit_tactic_expr = Tac2env.wit_ltac2_tac;
tactic_expr_entry = ltac2_expr;
})
open Vernacextend
let toplevel_selector = G_vernac.toplevel_selector
let pr_ltac2_selector s = Pp.(Goal_select.pr_goal_selector s ++ str ":")
let pr_ltac2_use_default b =
if b then (* Bug: a space is inserted before "..." *) str ".." else mt ()
let subprf = G_vernac.subprf
let subprf_with_selector = G_vernac.subprf_with_selector
}
VERNAC ARGUMENT EXTEND ltac2_selector PRINTED BY { pr_ltac2_selector }
| [ toplevel_selector(s) ] -> { s }
END
VERNAC ARGUMENT EXTEND ltac2_use_default PRINTED BY { pr_ltac2_use_default }
| [ "." ] -> { false }
| [ "..." ] -> { true }
END
VERNAC { tac2mode } EXTEND VernacLtac2
| ![proof] [ ltac2_selector_opt(g) ltac2_expr(t) ltac2_use_default(with_end_tac) ] =>
{ classify_as_proofstep } -> { fun ~pstate ->
Tac2entries.call ~pstate g ~with_end_tac t
}
| ![proof] [ "par" ":" ltac2_expr(t) ltac2_use_default(with_end_tac) ] =>
{ classify_as_proofstep } -> { fun ~pstate ->
Tac2entries.call_par ~pstate ~with_end_tac t
}
END
GRAMMAR EXTEND Gram
GLOBAL: tac2mode;
tac2mode: TOP
[ [ p = subprf -> { Vernacexpr.VernacSynPure p }
| g = OPT toplevel_selector; p = subprf_with_selector -> { Vernacexpr.VernacSynPure (p g) }
] ];
END
{
open Stdarg
let test_ltac2_ident_aux =
let open Procq.Lookahead in
to_entry "test_ltac2_ident" begin
lk_kw "Ltac2" >> lk_ident
end
}
VERNAC ARGUMENT EXTEND test_ltac2_ident PRINTED BY { fun _ -> Pp.mt() }
| [ test_ltac2_ident_aux(x) ] -> { x }
END
VERNAC COMMAND EXTEND Ltac2Printers CLASSIFIED AS QUERY
| [ "Print" test_ltac2_ident(_test) "Ltac2" reference(tac) ] -> { Tac2entries.print_ltac2 tac }
| [ "Print" "Ltac2" "Type" reference(tac) ] -> { Tac2entries.print_ltac2_type tac }
| [ "Locate" "Ltac2" reference(r) ] -> { Tac2entries.print_located_tactic r }
| [ "Print" "Ltac2" "Signatures" ] -> { Tac2entries.print_signatures () }
| [ "Ltac2" "Check" ltac2_expr(e) ] -> { Tac2entries.typecheck_expr e }
| [ "Ltac2" "Globalize" ltac2_expr(e) ] -> { Tac2entries.globalize_expr e }
END
[ Original von:0.94Diese Quellcodebibliothek enthält Beispiele in vielen Programmiersprachen.
Man kann per Verzeichnistruktur darin navigieren.
Der Code wird farblich markiert angezeigt.
]
|
2026-03-28
|