refactor(library/tactic/user_attribute,init/meta/attribute): merge caching_user_attribute into user_attribute
The inheritance-based approach doesn't scale to a second subclass for parameterized attributes
This commit is contained in:
parent
3aa5ebb8bd
commit
3188c4cbcf
16 changed files with 99 additions and 94 deletions
|
|
@ -9,9 +9,16 @@ import init.meta.tactic init.meta.rb_map init.meta.has_reflect
|
|||
meta constant attribute.get_instances : name → tactic (list name)
|
||||
meta constant attribute.fingerprint : name → tactic nat
|
||||
|
||||
meta structure user_attribute :=
|
||||
(name : name)
|
||||
(descr : string)
|
||||
meta structure user_attribute_cache_cfg (cache_ty : Type) :=
|
||||
(mk_cache : list name → tactic cache_ty)
|
||||
(dependencies : list name)
|
||||
|
||||
meta def user_attribute.dflt_cache_cfg : tactic unit :=
|
||||
tactic.exact `(⟨λ _, pure (), []⟩ : user_attribute_cache_cfg unit)
|
||||
|
||||
meta structure user_attribute (cache_ty : Type := unit) :=
|
||||
(name : name)
|
||||
(descr : string)
|
||||
/- Optional handler that will be called after the attribute has been applied to a declaration.
|
||||
Failing the tactic will fail the entire `attribute/def/...` command, i.e. the attribute will
|
||||
not be applied after all.
|
||||
|
|
@ -20,33 +27,35 @@ meta structure user_attribute :=
|
|||
(after_set : option (Π (decl : _root_.name) (prio : nat) (persistent : bool), command) := none)
|
||||
/- Optional handler that will be called before the attribute is removed from a declaration. -/
|
||||
(before_unset : option (Π (decl : _root_.name) (persistent : bool), command) := none)
|
||||
(cache_cfg : user_attribute_cache_cfg cache_ty . user_attribute.dflt_cache_cfg)
|
||||
|
||||
/- Registers a new user-defined attribute. The argument must be the name of a definition of type
|
||||
`user_attribute` or a sub-structure. -/
|
||||
meta def attribute.register (decl : name) : command :=
|
||||
tactic.set_basic_attribute ``user_attribute decl tt
|
||||
|
||||
meta structure caching_user_attribute (α : Type) extends user_attribute :=
|
||||
(mk_cache : list _root_.name → tactic α)
|
||||
(dependencies : list _root_.name)
|
||||
meta constant user_attribute.get_cache {α β : Type} (attr : user_attribute α β) : tactic α
|
||||
|
||||
meta constant caching_user_attribute.get_cache : Π {α : Type}, caching_user_attribute α → tactic α
|
||||
|
||||
open tactic
|
||||
|
||||
meta def register_attribute := attribute.register
|
||||
|
||||
meta def get_attribute_cache_dyn {α : Type} [reflected α] (name : name) : tactic α :=
|
||||
let attr : pexpr := expr.const name [] in
|
||||
do e ← to_expr ``(user_attribute.get_cache %%attr),
|
||||
t ← eval_expr (tactic α) e,
|
||||
t
|
||||
|
||||
meta def mk_name_set_attr (attr_name : name) : command :=
|
||||
do let t := `(caching_user_attribute name_set),
|
||||
do let t := `(user_attribute name_set),
|
||||
let v := `({name := attr_name,
|
||||
descr := "name_set attribute",
|
||||
descr := "name_set attribute",
|
||||
cache_cfg := {
|
||||
mk_cache := λ ns, return (name_set.of_list ns),
|
||||
dependencies := [] } : caching_user_attribute name_set),
|
||||
dependencies := []}} : user_attribute name_set),
|
||||
add_meta_definition attr_name [] t v,
|
||||
register_attribute attr_name
|
||||
|
||||
meta def get_name_set_for_attr (attr_name : name) : tactic name_set :=
|
||||
do
|
||||
cnst ← return (expr.const attr_name []),
|
||||
attr ← eval_expr (caching_user_attribute name_set) cnst,
|
||||
caching_user_attribute.get_cache attr
|
||||
meta def get_name_set_for_attr (name : name) : tactic name_set :=
|
||||
get_attribute_cache_dyn name
|
||||
|
|
|
|||
|
|
@ -112,7 +112,7 @@ section
|
|||
universe u
|
||||
|
||||
@[user_attribute]
|
||||
meta def monotonicity := { user_attribute . name := `monotonicity, descr := "Monotonicity rules for predicates" }
|
||||
meta def monotonicity : user_attribute := { name := `monotonicity, descr := "Monotonicity rules for predicates" }
|
||||
|
||||
lemma monotonicity.pi {α : Sort u} {p q : α → Prop} (h : ∀a, implies (p a) (q a)) :
|
||||
implies (Πa, p a) (Πa, q a) :=
|
||||
|
|
|
|||
|
|
@ -335,20 +335,18 @@ meta def to_simp_lemmas : simp_lemmas → list name → tactic simp_lemmas
|
|||
| S (n::ns) := do S' ← S.add_simp n, to_simp_lemmas S' ns
|
||||
|
||||
meta def mk_simp_attr (attr_name : name) : command :=
|
||||
do let t := `(caching_user_attribute simp_lemmas),
|
||||
do let t := `(user_attribute simp_lemmas),
|
||||
let v := `({name := attr_name,
|
||||
descr := "simplifier attribute",
|
||||
descr := "simplifier attribute",
|
||||
cache_cfg := {
|
||||
mk_cache := λ ns, do {tactic.to_simp_lemmas simp_lemmas.mk ns},
|
||||
dependencies := [`reducibility] } : caching_user_attribute simp_lemmas),
|
||||
dependencies := [`reducibility]}} : user_attribute simp_lemmas),
|
||||
add_decl (declaration.defn attr_name [] t v reducibility_hints.abbrev ff),
|
||||
attribute.register attr_name
|
||||
|
||||
meta def get_user_simp_lemmas (attr_name : name) : tactic simp_lemmas :=
|
||||
if attr_name = `default then simp_lemmas.mk_default
|
||||
else do
|
||||
cnst ← return (expr.const attr_name []),
|
||||
attr ← eval_expr (caching_user_attribute simp_lemmas) cnst,
|
||||
caching_user_attribute.get_cache attr
|
||||
else get_attribute_cache_dyn attr_name
|
||||
|
||||
meta def join_user_simp_lemmas_core : simp_lemmas → list name → tactic simp_lemmas
|
||||
| S [] := return S
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ meta def to_hinst_lemmas_core (m : transparency) : bool → list name → hinst_
|
|||
end
|
||||
|
||||
meta def mk_hinst_lemma_attr_core (attr_name : name) (as_simp : bool) : command :=
|
||||
do let t := `(caching_user_attribute hinst_lemmas),
|
||||
do let t := `(user_attribute hinst_lemmas),
|
||||
let v := `({name := attr_name,
|
||||
descr := "hinst_lemma attribute",
|
||||
after_set := some $ λ n _ _,
|
||||
|
|
@ -87,8 +87,9 @@ do let t := `(caching_user_attribute hinst_lemmas),
|
|||
fail format!"invalid ematch lemma '{n}'",
|
||||
-- allow unsetting
|
||||
before_unset := some $ λ _ _, skip,
|
||||
mk_cache := λ ns, to_hinst_lemmas_core reducible as_simp ns hinst_lemmas.mk,
|
||||
dependencies := [`reducibility] } : caching_user_attribute hinst_lemmas),
|
||||
cache_cfg := {
|
||||
mk_cache := λ ns, to_hinst_lemmas_core reducible as_simp ns hinst_lemmas.mk,
|
||||
dependencies := [`reducibility]}} : user_attribute hinst_lemmas),
|
||||
add_decl (declaration.defn attr_name [] t v reducibility_hints.abbrev ff),
|
||||
attribute.register attr_name
|
||||
|
||||
|
|
@ -98,7 +99,7 @@ meta def mk_hinst_lemma_attrs_core (as_simp : bool) : list name → command
|
|||
(mk_hinst_lemma_attr_core n as_simp >> mk_hinst_lemma_attrs_core ns)
|
||||
<|>
|
||||
(do type ← infer_type (expr.const n []),
|
||||
let expected := `(caching_user_attribute hinst_lemmas),
|
||||
let expected := `(user_attribute),
|
||||
(is_def_eq type expected
|
||||
<|> fail format!"failed to create hinst_lemma attribute '{n}', declaration already exists and has different type."),
|
||||
mk_hinst_lemma_attrs_core ns)
|
||||
|
|
@ -111,7 +112,7 @@ meta def merge_hinst_lemma_attrs (m : transparency) (as_simp : bool) : list name
|
|||
merge_hinst_lemma_attrs attrs new_hs
|
||||
|
||||
/--
|
||||
Create a new "cached" attribute (attr_name : caching_user_attribute hinst_lemmas).
|
||||
Create a new "cached" attribute (attr_name : user_attribute hinst_lemmas).
|
||||
It also creates "cached" attributes for each attr_names and simp_attr_names if they have not been defined
|
||||
yet. Moreover, the hinst_lemmas for attr_name will be the union of the lemmas tagged with
|
||||
attr_name, attrs_name, and simp_attr_names.
|
||||
|
|
@ -120,7 +121,7 @@ For the ones in simp_attr_names, we use the left-hand-side of the conclusion as
|
|||
meta def mk_hinst_lemma_attr_set (attr_name : name) (attr_names : list name) (simp_attr_names : list name) : command :=
|
||||
do mk_hinst_lemma_attrs_core ff attr_names,
|
||||
mk_hinst_lemma_attrs_core tt simp_attr_names,
|
||||
let t := `(caching_user_attribute hinst_lemmas),
|
||||
let t := `(user_attribute hinst_lemmas),
|
||||
let v := `({name := attr_name,
|
||||
descr := "hinst_lemma attribute set",
|
||||
after_set := some $ λ n _ _,
|
||||
|
|
@ -128,19 +129,17 @@ do mk_hinst_lemma_attrs_core ff attr_names,
|
|||
fail format!"invalid ematch lemma '{n}'",
|
||||
-- allow unsetting
|
||||
before_unset := some $ λ _ _, skip,
|
||||
mk_cache := λ ns, do {
|
||||
hs₁ ← to_hinst_lemmas_core reducible ff ns hinst_lemmas.mk,
|
||||
hs₂ ← merge_hinst_lemma_attrs reducible ff attr_names hs₁,
|
||||
merge_hinst_lemma_attrs reducible tt simp_attr_names hs₂},
|
||||
dependencies := [`reducibility] ++ attr_names ++ simp_attr_names } : caching_user_attribute hinst_lemmas),
|
||||
cache_cfg := {
|
||||
mk_cache := λ ns, do {
|
||||
hs₁ ← to_hinst_lemmas_core reducible ff ns hinst_lemmas.mk,
|
||||
hs₂ ← merge_hinst_lemma_attrs reducible ff attr_names hs₁,
|
||||
merge_hinst_lemma_attrs reducible tt simp_attr_names hs₂},
|
||||
dependencies := [`reducibility] ++ attr_names ++ simp_attr_names}} : user_attribute hinst_lemmas),
|
||||
add_decl (declaration.defn attr_name [] t v reducibility_hints.abbrev ff),
|
||||
attribute.register attr_name
|
||||
|
||||
meta def get_hinst_lemmas_for_attr (attr_name : name) : tactic hinst_lemmas :=
|
||||
do
|
||||
cnst ← return (expr.const attr_name []),
|
||||
attr ← eval_expr (caching_user_attribute hinst_lemmas) cnst,
|
||||
caching_user_attribute.get_cache attr
|
||||
get_attribute_cache_dyn attr_name
|
||||
|
||||
structure ematch_config :=
|
||||
(max_instances : nat := 10000)
|
||||
|
|
|
|||
|
|
@ -29,9 +29,10 @@ private meta def to_hinst_lemmas (m : transparency) (ex : name_set) : list name
|
|||
We say `ex_attr_name` is the "exception set". It is useful for excluding lemmas in `simp_attr_name`
|
||||
which are not good or redundant for ematching. -/
|
||||
meta def mk_hinst_lemma_attr_from_simp_attr (attr_decl_name attr_name : name) (simp_attr_name : name) (ex_attr_name : name) : command :=
|
||||
do let t := `(caching_user_attribute hinst_lemmas),
|
||||
do let t := `(user_attribute hinst_lemmas),
|
||||
let v := `({name := attr_name,
|
||||
descr := sformat!"hinst_lemma attribute derived from '{simp_attr_name}'",
|
||||
descr := sformat!"hinst_lemma attribute derived from '{simp_attr_name}'",
|
||||
cache_cfg := {
|
||||
mk_cache := λ ns,
|
||||
let aux := simp_attr_name in
|
||||
let ex_attr := ex_attr_name in
|
||||
|
|
@ -41,7 +42,7 @@ do let t := `(caching_user_attribute hinst_lemmas),
|
|||
ex ← get_name_set_for_attr ex_attr,
|
||||
to_hinst_lemmas reducible ex ss hs
|
||||
},
|
||||
dependencies := [`reducibility, simp_attr_name]} : caching_user_attribute hinst_lemmas),
|
||||
dependencies := [`reducibility, simp_attr_name]}} : user_attribute hinst_lemmas),
|
||||
add_decl (declaration.defn attr_decl_name [] t v reducibility_hints.abbrev ff),
|
||||
attribute.register attr_decl_name
|
||||
|
||||
|
|
|
|||
|
|
@ -27,7 +27,6 @@ name const * g_bool = nullptr;
|
|||
name const * g_bool_ff = nullptr;
|
||||
name const * g_bool_tt = nullptr;
|
||||
name const * g_combinator_K = nullptr;
|
||||
name const * g_caching_user_attribute = nullptr;
|
||||
name const * g_cast = nullptr;
|
||||
name const * g_cast_heq = nullptr;
|
||||
name const * g_char = nullptr;
|
||||
|
|
@ -404,7 +403,6 @@ void initialize_constants() {
|
|||
g_bool_ff = new name{"bool", "ff"};
|
||||
g_bool_tt = new name{"bool", "tt"};
|
||||
g_combinator_K = new name{"combinator", "K"};
|
||||
g_caching_user_attribute = new name{"caching_user_attribute"};
|
||||
g_cast = new name{"cast"};
|
||||
g_cast_heq = new name{"cast_heq"};
|
||||
g_char = new name{"char"};
|
||||
|
|
@ -782,7 +780,6 @@ void finalize_constants() {
|
|||
delete g_bool_ff;
|
||||
delete g_bool_tt;
|
||||
delete g_combinator_K;
|
||||
delete g_caching_user_attribute;
|
||||
delete g_cast;
|
||||
delete g_cast_heq;
|
||||
delete g_char;
|
||||
|
|
@ -1159,7 +1156,6 @@ name const & get_bool_name() { return *g_bool; }
|
|||
name const & get_bool_ff_name() { return *g_bool_ff; }
|
||||
name const & get_bool_tt_name() { return *g_bool_tt; }
|
||||
name const & get_combinator_K_name() { return *g_combinator_K; }
|
||||
name const & get_caching_user_attribute_name() { return *g_caching_user_attribute; }
|
||||
name const & get_cast_name() { return *g_cast; }
|
||||
name const & get_cast_heq_name() { return *g_cast_heq; }
|
||||
name const & get_char_name() { return *g_char; }
|
||||
|
|
|
|||
|
|
@ -29,7 +29,6 @@ name const & get_bool_name();
|
|||
name const & get_bool_ff_name();
|
||||
name const & get_bool_tt_name();
|
||||
name const & get_combinator_K_name();
|
||||
name const & get_caching_user_attribute_name();
|
||||
name const & get_cast_name();
|
||||
name const & get_cast_heq_name();
|
||||
name const & get_char_name();
|
||||
|
|
|
|||
|
|
@ -22,7 +22,6 @@ bool
|
|||
bool.ff
|
||||
bool.tt
|
||||
combinator.K
|
||||
caching_user_attribute
|
||||
cast
|
||||
cast_heq
|
||||
char
|
||||
|
|
|
|||
|
|
@ -423,10 +423,9 @@ vm_obj mk_smt_state(tactic_state s, smt_config const & cfg) {
|
|||
|
||||
static hinst_lemmas get_hinst_lemmas(name const & attr_name, tactic_state const & s) {
|
||||
auto & S = get_vm_state();
|
||||
vm_obj attr = S.get_constant(attr_name);
|
||||
vm_obj r = caching_user_attribute_get_cache(mk_vm_unit(), attr, to_obj(s));
|
||||
vm_obj r = user_attribute_get_cache(S, s, attr_name);
|
||||
if (tactic::is_result_exception(r))
|
||||
throw exception(sstream() << "failed to initialize sm_state, failed to retrieve attribute '" << attr_name << "'");
|
||||
throw exception(sstream() << "failed to initialize smt_state, failed to retrieve attribute '" << attr_name << "'");
|
||||
vm_obj lemmas = tactic::get_result_value(r);
|
||||
if (!is_hinst_lemmas(lemmas))
|
||||
throw exception(sstream() << "failed to initialize smt_state, attribute '" << attr_name << "' is not a hinst_lemmas");
|
||||
|
|
@ -436,9 +435,9 @@ static hinst_lemmas get_hinst_lemmas(name const & attr_name, tactic_state const
|
|||
static simp_lemmas get_simp_lemmas(name const & attr_name, tactic_state const & s) {
|
||||
auto & S = get_vm_state();
|
||||
vm_obj attr = S.get_constant(attr_name);
|
||||
vm_obj r = caching_user_attribute_get_cache(mk_vm_unit(), attr, to_obj(s));
|
||||
vm_obj r = user_attribute_get_cache(S, s, attr_name);
|
||||
if (tactic::is_result_exception(r))
|
||||
throw exception(sstream() << "failed to initialize sm_state, failed to retrieve attribute '" << attr_name << "'");
|
||||
throw exception(sstream() << "failed to initialize smt_state, failed to retrieve attribute '" << attr_name << "'");
|
||||
vm_obj lemmas = tactic::get_result_value(r);
|
||||
if (!is_simp_lemmas(lemmas))
|
||||
throw exception(sstream() << "failed to initialize smt_state, attribute '" << attr_name << "' is not a simp_lemmas");
|
||||
|
|
|
|||
|
|
@ -44,29 +44,25 @@ static environment update(environment const & env, user_attr_ext const & ext) {
|
|||
|
||||
static environment add_user_attr(environment const & env, name const & d) {
|
||||
auto const & ty = env.get(d).get_type();
|
||||
if (!is_constant(ty, get_user_attribute_name()) && !is_constant(get_app_fn(ty), get_caching_user_attribute_name()))
|
||||
throw exception("invalid [user_attribute], must be applied to definition of type user_attribute");
|
||||
if (!is_app_of(ty, get_user_attribute_name(), 2))
|
||||
throw exception("invalid [user_attribute] usage, must be applied to definition of type `user_attribute`");
|
||||
|
||||
vm_state vm(env, options());
|
||||
vm_obj o = vm.invoke(d, {});
|
||||
if (is_constant(get_app_fn(ty), get_caching_user_attribute_name()))
|
||||
o = cfield(o, 0);
|
||||
name const & n = to_name(cfield(o, 0));
|
||||
if (n.is_anonymous())
|
||||
vm_obj o = vm.get_constant(d);
|
||||
name const & attr_name = to_name(cfield(o, 0));
|
||||
if (attr_name.is_anonymous())
|
||||
throw exception(sstream() << "invalid user_attribute, anonymous attribute names are not allowed");
|
||||
if (is_attribute(env, n))
|
||||
throw exception(sstream() << "an attribute named [" << n << "] has already been registered");
|
||||
if (is_attribute(env, attr_name))
|
||||
throw exception(sstream() << "an attribute named [" << attr_name << "] has already been registered");
|
||||
std::string descr = to_string(cfield(o, 1));
|
||||
after_set_proc after_set;
|
||||
if (!is_none(cfield(o, 2))) {
|
||||
after_set = [=](environment const & env, io_state const & ios, name const & n, unsigned prio, bool persistent) {
|
||||
vm_state vm(env, ios.get_options());
|
||||
scope_vm_state scope(vm);
|
||||
vm_obj o = vm.invoke(d, {});
|
||||
if (is_constant(get_app_fn(ty), get_caching_user_attribute_name()))
|
||||
o = cfield(o, 0);
|
||||
vm_obj o = vm.get_constant(d);
|
||||
tactic_state s = mk_tactic_state_for(env, options(), {}, local_context(), mk_true());
|
||||
auto vm_r = vm.invoke(get_some_value(cfield(o, 2)), to_obj(n), to_obj(prio), mk_vm_bool(persistent), to_obj(s));
|
||||
auto vm_r = vm.invoke(get_some_value(cfield(o, 2)), to_obj(n), mk_vm_nat(prio), mk_vm_bool(persistent), to_obj(s));
|
||||
tactic::report_exception(vm, vm_r);
|
||||
return tactic::to_state(tactic::get_result_state(vm_r)).env();
|
||||
};
|
||||
|
|
@ -76,9 +72,7 @@ static environment add_user_attr(environment const & env, name const & d) {
|
|||
before_unset = [=](environment const & env, io_state const & ios, name const & n, bool persistent) {
|
||||
vm_state vm(env, ios.get_options());
|
||||
scope_vm_state scope(vm);
|
||||
vm_obj o = vm.invoke(d, {});
|
||||
if (is_constant(get_app_fn(ty), get_caching_user_attribute_name()))
|
||||
o = cfield(o, 0);
|
||||
vm_obj o = vm.get_constant(d);
|
||||
tactic_state s = mk_tactic_state_for(env, options(), {}, local_context(), mk_true());
|
||||
auto vm_r = vm.invoke(get_some_value(cfield(o, 3)), to_obj(n), mk_vm_bool(persistent), to_obj(s));
|
||||
tactic::report_exception(vm, vm_r);
|
||||
|
|
@ -87,7 +81,7 @@ static environment add_user_attr(environment const & env, name const & d) {
|
|||
}
|
||||
|
||||
user_attr_ext ext = get_extension(env);
|
||||
ext.m_attrs.insert(n, attribute_ptr(new basic_attribute(n, descr.c_str(), after_set, before_unset)));
|
||||
ext.m_attrs.insert(attr_name, attribute_ptr(new basic_attribute(attr_name, descr.c_str(), after_set, before_unset)));
|
||||
return update(env, ext);
|
||||
}
|
||||
|
||||
|
|
@ -166,11 +160,12 @@ static bool check_dep_fingerprints(environment const & env, list<name> const & d
|
|||
}
|
||||
}
|
||||
|
||||
vm_obj caching_user_attribute_get_cache(vm_obj const &, vm_obj const & vm_attr, vm_obj const & vm_s) {
|
||||
vm_obj user_attribute_get_cache_core(vm_obj const &, vm_obj const &, vm_obj const & vm_attr, vm_obj const & vm_s) {
|
||||
tactic_state const & s = tactic::to_state(vm_s);
|
||||
name const & n = to_name(cfield(cfield(vm_attr, 0), 0));
|
||||
vm_obj const & cache_handler = cfield(vm_attr, 1);
|
||||
list<name> const & deps = to_list_name(cfield(vm_attr, 2));
|
||||
name const & n = to_name(cfield(vm_attr, 0));
|
||||
vm_obj const & cache_cfg = cfield(vm_attr, 4);
|
||||
vm_obj const & cache_handler = cfield(cache_cfg, 0);
|
||||
list<name> const & deps = to_list_name(cfield(cache_cfg, 1));
|
||||
LEAN_TACTIC_TRY;
|
||||
environment const & env = s.env();
|
||||
attribute const & attr = get_attribute(env, n);
|
||||
|
|
@ -222,6 +217,11 @@ vm_obj caching_user_attribute_get_cache(vm_obj const &, vm_obj const & vm_attr,
|
|||
LEAN_TACTIC_CATCH(s);
|
||||
}
|
||||
|
||||
vm_obj user_attribute_get_cache(vm_state & S, tactic_state const & s, name const & attr_name) {
|
||||
vm_obj attr = S.get_constant(attr_name);
|
||||
return user_attribute_get_cache_core(mk_vm_unit(), mk_vm_unit(), attr, to_obj(s));
|
||||
}
|
||||
|
||||
vm_obj set_basic_attribute(vm_obj const & vm_attr_n, vm_obj const & vm_n, vm_obj const & p, vm_obj const & vm_prio, vm_obj const & vm_s) {
|
||||
name const & attr_n = to_name(vm_attr_n);
|
||||
name const & n = to_name(vm_n);
|
||||
|
|
@ -273,7 +273,7 @@ vm_obj has_attribute(vm_obj const & vm_attr_n, vm_obj const & vm_n, vm_obj const
|
|||
void initialize_user_attribute() {
|
||||
DECLARE_VM_BUILTIN(name({"attribute", "get_instances"}), attribute_get_instances);
|
||||
DECLARE_VM_BUILTIN(name({"attribute", "fingerprint"}), attribute_fingerprint);
|
||||
DECLARE_VM_BUILTIN(name({"caching_user_attribute", "get_cache"}), caching_user_attribute_get_cache);
|
||||
DECLARE_VM_BUILTIN(name({"user_attribute", "get_cache"}), user_attribute_get_cache_core);
|
||||
DECLARE_VM_BUILTIN(name({"tactic", "set_basic_attribute"}), set_basic_attribute);
|
||||
DECLARE_VM_BUILTIN(name({"tactic", "unset_attribute"}), unset_attribute);
|
||||
DECLARE_VM_BUILTIN(name({"tactic", "has_attribute"}), has_attribute);
|
||||
|
|
|
|||
|
|
@ -6,9 +6,10 @@ Author: Sebastian Ullrich
|
|||
*/
|
||||
#pragma once
|
||||
#include "library/vm/vm.h"
|
||||
#include "library/tactic/tactic_state.h"
|
||||
|
||||
namespace lean {
|
||||
vm_obj caching_user_attribute_get_cache(vm_obj const &, vm_obj const & vm_attr, vm_obj const & vm_s);
|
||||
vm_obj user_attribute_get_cache(vm_state & S, tactic_state const & s, name const & attr_name);
|
||||
void initialize_user_attribute();
|
||||
void finalize_user_attribute();
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,21 +1,25 @@
|
|||
@[user_attribute]
|
||||
meta def foo_attr : caching_user_attribute string :=
|
||||
meta def foo_attr : user_attribute string :=
|
||||
{ name := `foo, descr := "bar",
|
||||
mk_cache := λ ns, return $ string.join (list.map (λ n, to_string n ++ "\n") ns),
|
||||
dependencies := [] }
|
||||
cache_cfg := {
|
||||
mk_cache := λ ns, return $ string.join (list.map (λ n, to_string n ++ "\n") ns),
|
||||
dependencies := []} }
|
||||
|
||||
attribute [foo] eq.refl eq.mp
|
||||
|
||||
set_option trace.user_attributes_cache true
|
||||
|
||||
run_cmd do
|
||||
s : string ← caching_user_attribute.get_cache foo_attr,
|
||||
s : string ← foo_attr.get_cache,
|
||||
tactic.trace s,
|
||||
s : string ← caching_user_attribute.get_cache foo_attr,
|
||||
tactic.trace s,
|
||||
tactic.set_basic_attribute `foo ``eq.mpr,
|
||||
s : string ← caching_user_attribute.get_cache foo_attr,
|
||||
s : string ← foo_attr.get_cache,
|
||||
tactic.trace s
|
||||
|
||||
attribute [foo] eq.mpr
|
||||
|
||||
run_cmd do
|
||||
s : string ← foo_attr.get_cache,
|
||||
tactic.trace s,
|
||||
tactic.set_basic_attribute `reducible ``eq.mp, -- should not affect [foo] cache
|
||||
s : string ← caching_user_attribute.get_cache foo_attr,
|
||||
s : string ← foo_attr.get_cache,
|
||||
tactic.trace s
|
||||
|
|
|
|||
|
|
@ -27,7 +27,6 @@ run_cmd script_check_id `bool
|
|||
run_cmd script_check_id `bool.ff
|
||||
run_cmd script_check_id `bool.tt
|
||||
run_cmd script_check_id `combinator.K
|
||||
run_cmd script_check_id `caching_user_attribute
|
||||
run_cmd script_check_id `cast
|
||||
run_cmd script_check_id `cast_heq
|
||||
run_cmd script_check_id `char
|
||||
|
|
|
|||
|
|
@ -1,17 +1,18 @@
|
|||
open tactic
|
||||
@[user_attribute]
|
||||
meta def my_attr : caching_user_attribute (name → bool) :=
|
||||
meta def my_attr : user_attribute (name → bool) :=
|
||||
{ name := "my_attr",
|
||||
descr := "my attr",
|
||||
mk_cache := λ ls, do {
|
||||
let c := `(λ n : name, (name.cases_on n ff (λ _ _, to_bool (n ∈ ls)) (λ _ _, ff) : bool)),
|
||||
eval_expr (name → bool) c
|
||||
},
|
||||
dependencies := []
|
||||
cache_cfg := {
|
||||
mk_cache := λ ls, do {
|
||||
let c := `(λ n : name, (name.cases_on n ff (λ _ _, to_bool (n ∈ ls)) (λ _ _, ff) : bool)),
|
||||
eval_expr (name → bool) c
|
||||
},
|
||||
dependencies := []}
|
||||
}
|
||||
|
||||
meta def my_tac : tactic unit :=
|
||||
do f ← caching_user_attribute.get_cache my_attr,
|
||||
do f ← my_attr.get_cache,
|
||||
trace (f `foo),
|
||||
return ()
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
variable a : caching_user_attribute string
|
||||
variable a : user_attribute string
|
||||
variable b : string
|
||||
|
||||
#check a = b
|
||||
|
|
|
|||
|
|
@ -5,4 +5,4 @@ term
|
|||
has type
|
||||
string
|
||||
but is expected to have type
|
||||
caching_user_attribute string
|
||||
(user_attribute string)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue