diff options
author | Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> | 2017-07-11 15:42:43 +0200 |
---|---|---|
committer | Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> | 2017-07-11 15:54:46 +0200 |
commit | 91df402729f70144a4e4d198c4384dc515920e59 (patch) | |
tree | c750afbc9119b7da597235bb62432ff42c871e25 | |
parent | c401fc96c3271746448600ca097876bd139b10e9 (diff) |
Moving the last bits of abtraction-breaking code out of the kernel.
-rw-r--r-- | API/API.mli | 2 | ||||
-rw-r--r-- | kernel/declareops.ml | 18 | ||||
-rw-r--r-- | kernel/declareops.mli | 7 | ||||
-rw-r--r-- | kernel/univ.mli | 5 | ||||
-rw-r--r-- | library/global.ml | 17 | ||||
-rw-r--r-- | library/heads.ml | 2 | ||||
-rw-r--r-- | printing/prettyp.ml | 11 |
7 files changed, 30 insertions, 32 deletions
diff --git a/API/API.mli b/API/API.mli index 029f458cc..9f7a6ded8 100644 --- a/API/API.mli +++ b/API/API.mli @@ -4669,8 +4669,6 @@ sig val constant_has_body : Declarations.constant_body -> bool val is_opaque : Declarations.constant_body -> bool val eq_recarg : Declarations.recarg -> Declarations.recarg -> bool - val body_of_constant : - Opaqueproof.opaquetab -> Declarations.constant_body -> Term.constr option end module Constr : diff --git a/kernel/declareops.ml b/kernel/declareops.ml index cf6d3c55e..efce21982 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -44,29 +44,11 @@ let hcons_template_arity ar = (** {6 Constants } *) -let instantiate cb c = - match cb.const_universes with - | Monomorphic_const _ -> c - | Polymorphic_const ctx -> - Vars.subst_instance_constr (Univ.AUContext.instance ctx) c - let constant_is_polymorphic cb = match cb.const_universes with | Monomorphic_const _ -> false | Polymorphic_const _ -> true -let body_of_constant otab cb = match cb.const_body with - | Undef _ -> None - | Def c -> Some (instantiate cb (force_constr c)) - | OpaqueDef o -> Some (instantiate cb (Opaqueproof.force_proof otab o)) - -let type_of_constant cb = - match cb.const_type with - | RegularArity t as x -> - let t' = instantiate cb t in - if t' == t then x else RegularArity t' - | TemplateArity _ as x -> x - let constant_has_body cb = match cb.const_body with | Undef _ -> false | Def _ | OpaqueDef _ -> true diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 987c1adaf..a8ba5fa39 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -32,13 +32,6 @@ val constant_polymorphic_context : constant_body -> abstract_universe_context (** Is the constant polymorphic? *) val constant_is_polymorphic : constant_body -> bool -(** Accessing const_body, forcing access to opaque proof term if needed. - Only use this function if you know what you're doing. *) - -val body_of_constant : - Opaqueproof.opaquetab -> constant_body -> Term.constr option -val type_of_constant : constant_body -> constant_type - (** Return the universe context, in case the definition is polymorphic, otherwise the context is empty. *) diff --git a/kernel/univ.mli b/kernel/univ.mli index 9d93ec26c..53297ac46 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -326,6 +326,7 @@ sig val empty : t val is_empty : t -> bool + (** Don't use. *) val instance : t -> Instance.t val size : t -> int @@ -460,10 +461,10 @@ val abstract_cumulativity_info : cumulativity_info -> universe_level_subst * abs val make_abstract_instance : abstract_universe_context -> universe_instance -(** Get the instantiated graph. *) +(** Don't use. *) val instantiate_univ_context : abstract_universe_context -> universe_context -(** Get the instantiated graphs for both universe constraints and subtyping constraints. *) +(** Don't use. *) val instantiate_cumulativity_info : abstract_cumulativity_info -> cumulativity_info (** {6 Pretty-printing of universes. } *) diff --git a/library/global.ml b/library/global.ml index 09c202c50..e90151bff 100644 --- a/library/global.ml +++ b/library/global.ml @@ -122,7 +122,22 @@ let lookup_modtype kn = lookup_modtype kn (env()) let exists_objlabel id = Safe_typing.exists_objlabel id (safe_env ()) let opaque_tables () = Environ.opaque_tables (env ()) -let body_of_constant_body cb = Declareops.body_of_constant (opaque_tables ()) cb + +let instantiate cb c = + let open Declarations in + match cb.const_universes with + | Monomorphic_const _ -> c + | Polymorphic_const ctx -> + Vars.subst_instance_constr (Univ.AUContext.instance ctx) c + +let body_of_constant_body cb = + let open Declarations in + let otab = opaque_tables () in + match cb.const_body with + | Undef _ -> None + | Def c -> Some (instantiate cb (Mod_subst.force_constr c)) + | OpaqueDef o -> Some (instantiate cb (Opaqueproof.force_proof otab o)) + let body_of_constant cst = body_of_constant_body (lookup_constant cst) (** Operations on kernel names *) diff --git a/library/heads.ml b/library/heads.ml index 0f420c0e6..a1cb81242 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -128,7 +128,7 @@ let compute_head = function let is_Def = function Declarations.Def _ -> true | _ -> false in let body = if cb.Declarations.const_proj = None && is_Def cb.Declarations.const_body - then Declareops.body_of_constant (Environ.opaque_tables env) cb else None + then Global.body_of_constant cst else None in (match body with | None -> RigidHead (RigidParameter cst) diff --git a/printing/prettyp.ml b/printing/prettyp.ml index d9bb97be1..ff12737f6 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -514,7 +514,16 @@ let print_instance sigma cb = let print_constant with_values sep sp = let cb = Global.lookup_constant sp in let val_0 = Global.body_of_constant_body cb in - let typ = Declareops.type_of_constant cb in + let typ = match cb.const_type with + | RegularArity t as x -> + begin match cb.const_universes with + | Monomorphic_const _ -> x + | Polymorphic_const univs -> + let inst = Univ.AUContext.instance univs in + RegularArity (Vars.subst_instance_constr inst t) + end + | TemplateArity _ as x -> x + in let typ = ungeneralized_type_of_constant_type typ in let univs = let otab = Global.opaque_tables () in |