michael/lean2
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(kernel/hits): add two builtin HITs: type_quotient and trunc

Browse source
This commit is contained in:
Leonardo de Moura 2015-04-23 15:27:56 -07:00
parent 591a563be3
commit 8241863abe
19 changed files with 275 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
hott/hit/coeq.hlean
View file

@ -13,7 +13,7 @@ import .type_quotient
open type_quotient eq equiv
namespace coeq
context
section
universe u
parameters {A B : Type.{u}} (f g : A → B)

8
hott/hit/colimit.hlean
View file

@ -12,7 +12,7 @@ Definition of general colimits and sequential colimits.
open eq nat type_quotient sigma equiv
namespace colimit
context
section
parameters {I J : Type} (A : I → Type) (dom cod : J → I)
(f : Π(j : J), A (dom j) → A (cod j))
variables {i : I} (a : A i) (j : J) (b : A (dom j))
@ -52,7 +52,7 @@ context
definition rec_cglue [reducible] {P : colimit → Type}
(Pincl : Π⦃i : I⦄ (x : A i), P (ι x))
(Pglue : Π(j : J) (x : A (dom j)), cglue j x ▹ Pincl (f j x) = Pincl x)
{j : J} (x : A (dom j)) : apD (rec Pincl Pglue) (cglue j x) = sorry ⬝ Pglue j x ⬝ sorry :=
{j : J} (x : A (dom j)) : apD (rec Pincl Pglue) (cglue j x) = Pglue j x :=
sorry
protected definition elim {P : Type} (Pincl : Π⦃i : I⦄ (x : A i), P)
@ -67,7 +67,7 @@ context
definition elim_cglue [reducible] {P : Type}
(Pincl : Π⦃i : I⦄ (x : A i), P)
(Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) = Pincl x)
{j : J} (x : A (dom j)) : ap (elim Pincl Pglue) (cglue j x) = sorry ⬝ Pglue j x ⬝ sorry :=
{j : J} (x : A (dom j)) : ap (elim Pincl Pglue) (cglue j x) = Pglue j x :=
sorry
protected definition elim_type (Pincl : Π⦃i : I⦄ (x : A i), Type)
@ -89,7 +89,7 @@ end colimit
/- definition of a sequential colimit -/
namespace seq_colim
context
section
parameters {A : ℕ → Type} (f : Π⦃n⦄, A n → A (succ n))
variables {n : ℕ} (a : A n)

2
hott/hit/cylinder.hlean
View file

@ -13,7 +13,7 @@ import .type_quotient
open type_quotient eq sum equiv
namespace cylinder
context
section
universe u
parameters {A B : Type.{u}} (f : A → B)

12
hott/hit/pushout.hlean
View file

@ -13,7 +13,7 @@ import .type_quotient
open type_quotient eq sum equiv
namespace pushout
context
section
parameters {TL BL TR : Type} (f : TL → BL) (g : TL → TR)
@ -54,16 +54,16 @@ parameters {TL BL TR : Type} (f : TL → BL) (g : TL → TR)
definition rec_inl {P : pushout → Type} (Pinl : Π(x : BL), P (inl x))
(Pinr : Π(x : TR), P (inr x)) (Pglue : Π(x : TL), glue x ▹ Pinl (f x) = Pinr (g x))
(x : BL) : rec Pinl Pinr Pglue (inl x) = Pinl x :=
rec_class_of _ _ _ --idp
idp
definition rec_inr {P : pushout → Type} (Pinl : Π(x : BL), P (inl x))
(Pinr : Π(x : TR), P (inr x)) (Pglue : Π(x : TL), glue x ▹ Pinl (f x) = Pinr (g x))
(x : TR) : rec Pinl Pinr Pglue (inr x) = Pinr x :=
rec_class_of _ _ _ --idp
idp
definition rec_glue {P : pushout → Type} (Pinl : Π(x : BL), P (inl x))
(Pinr : Π(x : TR), P (inr x)) (Pglue : Π(x : TL), glue x ▹ Pinl (f x) = Pinr (g x))
(x : TL) : apD (rec Pinl Pinr Pglue) (glue x) = sorry ⬝ Pglue x ⬝ sorry :=
(x : TL) : apD (rec Pinl Pinr Pglue) (glue x) = Pglue x :=
sorry
protected definition elim {P : Type} (Pinl : BL → P) (Pinr : TR → P)
@ -76,7 +76,7 @@ parameters {TL BL TR : Type} (f : TL → BL) (g : TL → TR)
definition elim_glue {P : Type} (Pinl : BL → P) (Pinr : TR → P)
(Pglue : Π(x : TL), Pinl (f x) = Pinr (g x)) (y : pushout) (x : TL)
: ap (elim Pinl Pinr Pglue) (glue x) = sorry ⬝ Pglue x ⬝ sorry :=
: ap (elim Pinl Pinr Pglue) (glue x) = Pglue x :=
sorry
protected definition elim_type (Pinl : BL → Type) (Pinr : TR → Type)
@ -109,7 +109,7 @@ end
{ intro b, cases b,
exact (inl _ _ ⋆),
exact (inr _ _ ⋆)},
{ intro b, cases b, apply rec_inl, apply rec_inr},
{ intro b, cases b, esimp, esimp},
{ intro x, fapply (pushout.rec_on _ _ x),
intro u, cases u, rewrite [↑function.compose,↑pushout.rec_on,rec_inl],
intro u, cases u, rewrite [↑function.compose,↑pushout.rec_on,rec_inr],

2
hott/hit/quotient.hlean
View file

@ -13,7 +13,7 @@ import .type_quotient .trunc
open eq is_trunc trunc type_quotient
namespace quotient
context
section
parameters {A : Type} (R : A → A → hprop)
-- set-quotients are just truncations of type-quotients
definition quotient : Type := trunc 0 (type_quotient (λa a', trunctype.carrier (R a a')))

2
hott/hit/trunc.hlean
View file

@ -20,7 +20,7 @@ namespace trunc
protected definition elim {n : trunc_index} {A : Type} {P : Type}
[Pt : is_trunc n P] (H : A → P) : trunc n A → P :=
rec H
trunc.rec H
protected definition elim_on {n : trunc_index} {A : Type} {P : Type} (aa : trunc n A)
[Pt : is_trunc n P] (H : A → P) : P :=

6
hott/hit/type_quotient.hlean
View file

@ -18,7 +18,7 @@ namespace type_quotient
protected definition elim {P : Type} (Pc : A → P) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a')
(x : type_quotient R) : P :=
rec Pc (λa a' H, !tr_constant ⬝ Pp H) x
type_quotient.rec Pc (λa a' H, !tr_constant ⬝ Pp H) x
protected definition elim_on [reducible] {P : Type} (x : type_quotient R)
(Pc : A → P) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') : P :=
@ -26,7 +26,7 @@ namespace type_quotient
protected definition elim_eq_of_rel {P : Type} (Pc : A → P)
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') {a a' : A} (H : R a a')
: ap (elim Pc Pp) (eq_of_rel H) = sorry ⬝ Pp H ⬝ sorry :=
: ap (elim Pc Pp) (eq_of_rel H) = Pp H :=
sorry
protected definition elim_type (Pc : A → Type)
@ -39,7 +39,7 @@ namespace type_quotient
protected definition elim_type_eq_of_rel (Pc : A → Type)
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a')
: transport (elim_type Pc Pp) (eq_of_rel H) = sorry /-to_fun (Pp H)-/ :=
: transport (elim_type Pc Pp) (eq_of_rel H) = to_fun (Pp H) :=
sorry
definition elim_type_uncurried (H : Σ(Pc : A → Type), Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a')

28
hott/init/hit.hlean
View file

@ -33,23 +33,17 @@ open is_trunc eq
constant trunc.{u} (n : trunc_index) (A : Type.{u}) : Type.{u}
namespace trunc
constant tr {n : trunc_index} {A : Type} (a : A) : trunc n A
constant is_trunc_trunc (n : trunc_index) (A : Type) : is_trunc n (trunc n A)
attribute is_trunc_trunc [instance]
/-protected-/ constant rec {n : trunc_index} {A : Type} {P : trunc n A → Type}
protected constant rec {n : trunc_index} {A : Type} {P : trunc n A → Type}
[Pt : Πaa, is_trunc n (P aa)] (H : Πa, P (tr a)) : Πaa, P aa
protected definition rec_on [reducible] {n : trunc_index} {A : Type} {P : trunc n A → Type}
(aa : trunc n A) [Pt : Πaa, is_trunc n (P aa)] (H : Πa, P (tr a)) : P aa :=
trunc.rec H aa
definition rec_tr [reducible] {n : trunc_index} {A : Type} {P : trunc n A → Type}
[Pt : Πaa, is_trunc n (P aa)] (H : Πa, P (tr a)) (a : A) : trunc.rec H (tr a) = H a :=
sorry --idp
end trunc
constant type_quotient.{u v} {A : Type.{u}} (R : A → A → Type.{v}) : Type.{max u v}
@ -61,7 +55,7 @@ namespace type_quotient
constant eq_of_rel {A : Type} {R : A → A → Type} {a a' : A} (H : R a a')
: class_of R a = class_of R a'
/-protected-/ constant rec {A : Type} {R : A → A → Type} {P : type_quotient R → Type}
protected constant rec {A : Type} {R : A → A → Type} {P : type_quotient R → Type}
(Pc : Π(a : A), P (class_of R a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), eq_of_rel H ▹ Pc a = Pc a')
(x : type_quotient R) : P x
@ -70,13 +64,23 @@ namespace type_quotient
(Pp : Π⦃a a' : A⦄ (H : R a a'), eq_of_rel H ▹ Pc a = Pc a') : P x :=
rec Pc Pp x
end type_quotient
init_hits -- Initialize builtin computational rules for trunc and type_quotient
namespace trunc
definition rec_tr [reducible] {n : trunc_index} {A : Type} {P : trunc n A → Type}
[Pt : Πaa, is_trunc n (P aa)] (H : Πa, P (tr a)) (a : A) : trunc.rec H (tr a) = H a :=
idp
end trunc
namespace type_quotient
definition rec_class_of {A : Type} {R : A → A → Type} {P : type_quotient R → Type}
(Pc : Π(a : A), P (class_of R a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), eq_of_rel H ▹ Pc a = Pc a')
(a : A) : rec Pc Pp (class_of R a) = Pc a :=
sorry --idp
(a : A) : type_quotient.rec Pc Pp (class_of R a) = Pc a :=
idp
constant rec_eq_of_rel {A : Type} {R : A → A → Type} {P : type_quotient R → Type}
(Pc : Π(a : A), P (class_of R a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), eq_of_rel H ▹ Pc a = Pc a')
{a a' : A} (H : R a a') : apD (rec Pc Pp) (eq_of_rel H) = sorry ⬝ Pp H ⬝ sorry
{a a' : A} (H : R a a') : apD (type_quotient.rec Pc Pp) (eq_of_rel H) = Pp H
end type_quotient

2
src/CMakeLists.txt
View file

@ -319,6 +319,8 @@ add_subdirectory(kernel/inductive)
set(LEAN_LIBS ${LEAN_LIBS} inductive)
add_subdirectory(kernel/quotient)
set(LEAN_LIBS ${LEAN_LIBS} quotient)
add_subdirectory(kernel/hits)
set(LEAN_LIBS ${LEAN_LIBS} hits)
add_subdirectory(library)
set(LEAN_LIBS ${LEAN_LIBS} library)
add_subdirectory(library/tactic)

11
src/frontends/lean/builtin_cmds.cpp
View file

@ -13,6 +13,7 @@ Author: Leonardo de Moura
#include "kernel/instantiate.h"
#include "kernel/inductive/inductive.h"
#include "kernel/quotient/quotient.h"
#include "kernel/hits/hits.h"
#include "kernel/default_converter.h"
#include "library/io_state_stream.h"
#include "library/scoped_ext.h"
@ -70,6 +71,7 @@ static void print_axioms(parser & p) {
name const & n = d.get_name();
if (!d.is_definition() &&
!is_quotient_decl(env, n) &&
!is_hits_decl(env, n) &&
!inductive::is_inductive_decl(env, n) &&
!inductive::is_elim_rule(env, n) &&
!inductive::is_intro_rule(env, n)) {
@ -674,9 +676,17 @@ static environment help_cmd(parser & p) {
}
environment init_quotient_cmd(parser & p) {
if (!(p.env().prop_proof_irrel() && p.env().impredicative()))
throw parser_error("invalid init_quotient command, this command is only available for kernels containing an impredicative and proof irrelevant Prop", p.cmd_pos());
return module::declare_quotient(p.env());
}
environment init_hits_cmd(parser & p) {
if (p.env().prop_proof_irrel() || p.env().impredicative())
throw parser_error("invalid init_hits command, this command is only available for proof relevant and predicative kernels", p.cmd_pos());
return module::declare_hits(p.env());
}
void init_cmd_table(cmd_table & r) {
add_cmd(r, cmd_info("open", "create aliases for declarations, and use objects defined in other namespaces",
open_cmd));
@ -694,6 +704,7 @@ void init_cmd_table(cmd_table & r) {
add_cmd(r, cmd_info("local", "define local attributes or notation", local_cmd));
add_cmd(r, cmd_info("help", "brief description of available commands and options", help_cmd));
add_cmd(r, cmd_info("init_quotient", "initialize quotient type computational rules", init_quotient_cmd));
add_cmd(r, cmd_info("init_hits", "initialize builtin HITs", init_hits_cmd));
add_cmd(r, cmd_info("#erase_cache", "erase cached definition (for debugging purposes)", erase_cache_cmd));
add_cmd(r, cmd_info("#projections", "generate projections for inductive datatype (for debugging purposes)", projections_cmd));
add_cmd(r, cmd_info("#telescope_eq", "(for debugging purposes)", telescope_eq_cmd));

2
src/frontends/lean/token_table.cpp
View file

@ -100,7 +100,7 @@ void init_token_table(token_table & t) {
"exit", "set_option", "open", "export", "calc_subst", "calc_refl", "calc_trans", "calc_symm", "tactic_hint",
"add_begin_end_tactic", "set_begin_end_tactic", "instance", "class",
"multiple_instances", "find_decl", "attribute", "persistent",
"include", "omit", "migrate", "init_quotient", "#erase_cache", "#projections", "#telescope_eq", nullptr};
"include", "omit", "migrate", "init_quotient", "init_hits", "#erase_cache", "#projections", "#telescope_eq", nullptr};
pair<char const *, char const *> aliases[] =
{{g_lambda_unicode, "fun"}, {"forall", "Pi"}, {g_forall_unicode, "Pi"}, {g_pi_unicode, "Pi"},

3
src/init/init.cpp
View file

@ -12,6 +12,7 @@ Author: Leonardo de Moura
#include "kernel/init_module.h"
#include "kernel/inductive/inductive.h"
#include "kernel/quotient/quotient.h"
#include "kernel/hits/hits.h"
#include "library/init_module.h"
#include "library/tactic/init_module.h"
#include "library/definitional/init_module.h"
@ -29,6 +30,7 @@ void initialize() {
initialize_kernel_module();
initialize_inductive_module();
initialize_quotient_module();
initialize_hits_module();
init_default_print_fn();
initialize_library_module();
initialize_tactic_module();
@ -42,6 +44,7 @@ void finalize() {
finalize_definitional_module();
finalize_tactic_module();
finalize_library_module();
finalize_hits_module();
finalize_quotient_module();
finalize_inductive_module();
finalize_kernel_module();

2
src/kernel/hits/CMakeLists.txt Normal file
View file

@ -0,0 +1,2 @@
add_library(hits hits.cpp)
target_link_libraries(hits ${LEAN_LIBS})

167
src/kernel/hits/hits.cpp Normal file
View file

@ -0,0 +1,167 @@
/*
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
Builtin HITs:
- n-truncation
- type quotients (non-truncated quotients)
*/
#include "util/sstream.h"
#include "kernel/kernel_exception.h"
#include "kernel/environment.h"
#include "kernel/hits/hits.h"
namespace lean {
static name * g_hits_extension = nullptr;
static name * g_trunc = nullptr;
static name * g_trunc_tr = nullptr;
static name * g_trunc_rec = nullptr;
static name * g_trunc_is_trunc_trunc = nullptr;
static name * g_type_quotient = nullptr;
static name * g_type_quotient_class_of = nullptr;
static name * g_type_quotient_rec = nullptr;
static name * g_type_quotient_eq_of_rel = nullptr;
static name * g_type_quotient_rec_eq_of_rel = nullptr;
struct hits_env_ext : public environment_extension {
bool m_initialized;
hits_env_ext():m_initialized(false){}
};
/** \brief Auxiliary object for registering the environment extension */
struct hits_env_ext_reg {
unsigned m_ext_id;
hits_env_ext_reg() { m_ext_id = environment::register_extension(std::make_shared<hits_env_ext>()); }
};
static hits_env_ext_reg * g_ext = nullptr;
/** \brief Retrieve environment extension */
static hits_env_ext const & get_extension(environment const & env) {
return static_cast<hits_env_ext const &>(env.get_extension(g_ext->m_ext_id));
}
/** \brief Update environment extension */
static environment update(environment const & env, hits_env_ext const & ext) {
return env.update(g_ext->m_ext_id, std::make_shared<hits_env_ext>(ext));
}
environment declare_hits(environment const & env) {
hits_env_ext ext = get_extension(env);
ext.m_initialized = true;
return update(env, ext);
}
optional<pair<expr, constraint_seq>> hits_normalizer_extension::operator()(expr const & e, extension_context & ctx) const {
environment const & env = ctx.env();
expr const & fn = get_app_fn(e);
if (!is_constant(fn))
return none_ecs();
hits_env_ext const & ext = get_extension(env);
if (!ext.m_initialized)
return none_ecs();
unsigned mk_pos;
name * mk_name;
unsigned f_pos;
if (const_name(fn) == *g_trunc_rec) {
mk_pos = 5;
mk_name = g_trunc_tr;
f_pos = 4;
} else if (const_name(fn) == *g_type_quotient_rec) {
mk_pos = 5;
mk_name = g_type_quotient_class_of;
f_pos = 3;
} else {
return none_ecs();
}
buffer<expr> args;
get_app_args(e, args);
if (args.size() <= mk_pos)
return none_ecs();
auto mk_cs = ctx.whnf(args[mk_pos]);
expr const & mk = mk_cs.first;
expr const & mk_fn = get_app_fn(mk);
if (!is_constant(mk_fn))
return none_ecs();
if (const_name(mk_fn) != *mk_name)
return none_ecs();
expr const & f = args[f_pos];
expr r = mk_app(f, app_arg(mk));
return some_ecs(r, mk_cs.second);
}
template<typename Ctx>
optional<expr> is_hits_meta_app_core(Ctx & ctx, expr const & e) {
expr const & fn = get_app_fn(e);
if (!is_constant(fn))
return none_expr();
unsigned mk_pos;
if (const_name(fn) == *g_trunc_rec) {
mk_pos = 5;
} else if (const_name(fn) == *g_type_quotient_rec) {
mk_pos = 5;
} else {
return none_expr();
}
buffer<expr> args;
get_app_args(e, args);
if (args.size() <= mk_pos)
return none_expr();
expr mk_app = ctx.whnf(args[mk_pos]).first;
return has_expr_metavar_strict(mk_app);
}
optional<expr> hits_normalizer_extension::may_reduce_later(expr const & e, extension_context & ctx) const {
return is_hits_meta_app_core(ctx, e);
}
bool hits_normalizer_extension::supports(name const & feature) const {
return feature == *g_hits_extension;
}
bool is_hits_decl(environment const & env, name const & n) {
if (!get_extension(env).m_initialized)
return false;
return
n == *g_trunc || n == *g_trunc_tr || n == *g_trunc_rec ||
n == *g_trunc_is_trunc_trunc ||
n == *g_type_quotient || n == *g_type_quotient_class_of ||
n == *g_type_quotient_rec || n == *g_type_quotient_eq_of_rel ||
n == *g_type_quotient_rec_eq_of_rel;
}
void initialize_hits_module() {
g_hits_extension = new name("hits_extension");
g_trunc = new name{"trunc"};
g_trunc_tr = new name{"trunc", "tr"};
g_trunc_rec = new name{"trunc", "rec"};
g_trunc_is_trunc_trunc = new name{"trunc", "is_trunc_trunc"};
g_type_quotient = new name{"type_quotient"};
g_type_quotient_class_of = new name{"type_quotient", "class_of"};
g_type_quotient_rec = new name{"type_quotient", "rec"};
g_type_quotient_eq_of_rel = new name{"type_quotient", "eq_of_rel"};
g_type_quotient_rec_eq_of_rel = new name{"type_quotient", "rec_eq_of_rel"};
g_ext = new hits_env_ext_reg();
}
void finalize_hits_module() {
delete g_ext;
delete g_hits_extension;
delete g_trunc;
delete g_trunc_tr;
delete g_trunc_rec;
delete g_trunc_is_trunc_trunc;
delete g_type_quotient;
delete g_type_quotient_class_of;
delete g_type_quotient_rec;
delete g_type_quotient_eq_of_rel;
delete g_type_quotient_rec_eq_of_rel;
}
}

28
src/kernel/hits/hits.h Normal file
View file

@ -0,0 +1,28 @@
/*
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
Builtin HITs:
- n-truncation
- type quotients (non-truncated quotients)
*/
#pragma once
namespace lean {
/** \brief Normalizer extension for applying builtin HITs computational rules. */
class hits_normalizer_extension : public normalizer_extension {
public:
virtual optional<pair<expr, constraint_seq>> operator()(expr const & e, extension_context & ctx) const;
virtual optional<expr> may_reduce_later(expr const & e, extension_context & ctx) const;
virtual bool supports(name const & feature) const;
};
/** \brief The following function must be invoked to register the builtin HITs computation rules in the kernel. */
environment declare_hits(environment const & env);
/** \brief Return true iff \c n is one of the HITs builtin constants. */
bool is_hits_decl(environment const & env, name const & n);
void initialize_hits_module();
void finalize_hits_module();
}

8
src/library/hott_kernel.cpp
View file

@ -1,10 +1,11 @@
/*
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Copyright (c) 2014-2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
*/
#include "kernel/inductive/inductive.h"
#include "kernel/hits/hits.h"
#include "library/inductive_unifier_plugin.h"
namespace lean {
@ -15,8 +16,9 @@ environment mk_hott_environment(unsigned trust_lvl) {
false /* Type.{0} is not proof irrelevant */,
true /* Eta */,
false /* Type.{0} is not impredicative */,
/* builtin support for inductive */
std::unique_ptr<normalizer_extension>(new inductive_normalizer_extension()));
/* builtin support for inductive and hits */
compose(std::unique_ptr<normalizer_extension>(new inductive_normalizer_extension()),
std::unique_ptr<normalizer_extension>(new hits_normalizer_extension())));
return set_unifier_plugin(env, mk_inductive_unifier_plugin());
}
}

18
src/library/module.cpp
View file

@ -21,6 +21,7 @@ Author: Leonardo de Moura
#include "util/name_map.h"
#include "kernel/type_checker.h"
#include "kernel/quotient/quotient.h"
#include "kernel/hits/hits.h"
#include "library/module.h"
#include "library/sorry.h"
#include "library/kernel_serializer.h"
@ -164,6 +165,7 @@ static std::string * g_glvl_key = nullptr;
static std::string * g_decl_key = nullptr;
static std::string * g_inductive = nullptr;
static std::string * g_quotient = nullptr;
static std::string * g_hits = nullptr;
namespace module {
environment add(environment const & env, std::string const & k, std::function<void(serializer &)> const & wr) {
@ -218,6 +220,19 @@ static void quotient_reader(deserializer &, module_idx, shared_environment & sen
});
}
environment declare_hits(environment const & env) {
environment new_env = ::lean::declare_hits(env);
return add(new_env, *g_hits, [=](serializer &) {});
}
static void hits_reader(deserializer &, module_idx, shared_environment & senv,
std::function<void(asynch_update_fn const &)> &,
std::function<void(delayed_update_fn const &)> &) {
senv.update([&](environment const & env) {
return ::lean::declare_hits(env);
});
}
environment add_inductive(environment env,
level_param_names const & level_params,
unsigned num_params,
@ -576,13 +591,16 @@ void initialize_module() {
g_decl_key = new std::string("decl");
g_inductive = new std::string("ind");
g_quotient = new std::string("quot");
g_hits = new std::string("hits");
register_module_object_reader(*g_inductive, module::inductive_reader);
register_module_object_reader(*g_quotient, module::quotient_reader);
register_module_object_reader(*g_hits, module::hits_reader);
}
void finalize_module() {
delete g_inductive;
delete g_quotient;
delete g_hits;
delete g_decl_key;
delete g_glvl_key;
delete g_object_readers;

3
src/library/module.h
View file

@ -109,6 +109,9 @@ environment add_inductive(environment env,
/** \brief The following function must be invoked to register the quotient type computation rules in the kernel. */
environment declare_quotient(environment const & env);
/** \brief The following function must be invoked to register the builtin HITs in the kernel. */
environment declare_hits(environment const & env);
/**
\brief Declare a single inductive datatype. This is just a helper function implemented on top of
the previous (more general) add_inductive.

3
tests/lean/hott/trunc_1.hlean
View file

@ -1,5 +1,5 @@
open is_trunc
namespace hide
inductive trunc (n : trunc_index) (A : Type) : Type :=
tr {} : A → trunc n A
@ -30,3 +30,4 @@ namespace trunc
by intro xx; apply (trunc_rec_on xx); intro x; exact (tr (f x))
end trunc
end hide