aboutsummaryrefslogtreecommitdiff
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/cbv.ml2
-rw-r--r--pretyping/cbv.mli2
-rw-r--r--pretyping/detyping.ml12
-rw-r--r--pretyping/evarsolve.mli7
-rw-r--r--pretyping/inductiveops.mli6
-rw-r--r--pretyping/miscops.ml3
-rw-r--r--pretyping/pretype_errors.ml13
-rw-r--r--pretyping/pretype_errors.mli18
-rw-r--r--pretyping/pretyping.ml107
-rw-r--r--pretyping/pretyping.mli5
-rw-r--r--pretyping/retyping.ml50
-rw-r--r--pretyping/retyping.mli5
-rw-r--r--pretyping/typeclasses.ml2
-rw-r--r--pretyping/typeclasses.mli6
-rw-r--r--pretyping/univdecls.ml22
15 files changed, 144 insertions, 116 deletions
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index 95de969260..192eca63bb 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -45,7 +45,7 @@ type cbv_value =
| LAM of int * (Name.t * constr) list * constr * cbv_value subs
| FIXP of fixpoint * cbv_value subs * cbv_value array
| COFIXP of cofixpoint * cbv_value subs * cbv_value array
- | CONSTR of constructor puniverses * cbv_value array
+ | CONSTR of constructor Univ.puniverses * cbv_value array
(* type of terms with a hole. This hole can appear only under App or Case.
* TOP means the term is considered without context
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index 5f9609a5c5..1d4c88ea22 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.mli
@@ -33,7 +33,7 @@ type cbv_value =
| LAM of int * (Name.t * constr) list * constr * cbv_value subs
| FIXP of fixpoint * cbv_value subs * cbv_value array
| COFIXP of cofixpoint * cbv_value subs * cbv_value array
- | CONSTR of constructor puniverses * cbv_value array
+ | CONSTR of constructor Univ.puniverses * cbv_value array
and cbv_stack =
| TOP
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 0d1e401d98..6527ba9355 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -414,15 +414,17 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
let eqnl = detype_eqns constructs constagsl bl in
GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl)
+let detype_universe sigma u =
+ let fn (l, n) = Some (Termops.reference_of_level sigma l, n) in
+ Univ.Universe.map fn u
+
let detype_sort sigma = function
| Prop Null -> GProp
| Prop Pos -> GSet
| Type u ->
GType
(if !print_universes
- then
- let u = Pp.string_of_ppcmds (Univ.Universe.pr_with (Termops.pr_evd_level sigma) u) in
- [Loc.tag @@ Name.mk_name (Id.of_string_soft u)]
+ then detype_universe sigma u
else [])
type binder_kind = BProd | BLambda | BLetIn
@@ -434,8 +436,8 @@ let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index
let set_detype_anonymous f = detype_anonymous := f
let detype_level sigma l =
- let l = Pp.string_of_ppcmds (Termops.pr_evd_level sigma l) in
- GType (Some (Loc.tag @@ Name.mk_name (Id.of_string_soft l)))
+ let l = Termops.reference_of_level sigma l in
+ GType (UNamed l)
let detype_instance sigma l =
let l = EInstance.kind sigma l in
diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli
index e5d288b5c3..703c4616c7 100644
--- a/pretyping/evarsolve.mli
+++ b/pretyping/evarsolve.mli
@@ -6,7 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Constr
open EConstr
open Evd
open Environ
@@ -49,7 +48,7 @@ val refresh_universes :
env -> evar_map -> types -> evar_map * types
val solve_refl : ?can_drop:bool -> conv_fun_bool -> env -> evar_map ->
- bool option -> existential_key -> constr array -> constr array -> evar_map
+ bool option -> Evar.t -> constr array -> constr array -> evar_map
val solve_evar_evar : ?force:bool ->
(env -> evar_map -> bool option -> existential -> constr -> evar_map) ->
@@ -78,10 +77,10 @@ exception IllTypedInstance of env * types * types
(* May raise IllTypedInstance if types are not convertible *)
val check_evar_instance :
- evar_map -> existential_key -> constr -> conv_fun -> evar_map
+ evar_map -> Evar.t -> constr -> conv_fun -> evar_map
val remove_instance_local_defs :
- evar_map -> existential_key -> 'a array -> 'a list
+ evar_map -> Evar.t -> 'a array -> 'a list
val get_type_of_refresh :
?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * types
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index febe99b0bc..58b1ce6c3f 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -28,8 +28,8 @@ val arities_of_constructors : env -> pinductive -> types array
reasoning either with only recursively uniform parameters or with all
parameters including the recursively non-uniform ones *)
type inductive_family
-val make_ind_family : inductive puniverses * constr list -> inductive_family
-val dest_ind_family : inductive_family -> inductive puniverses * constr list
+val make_ind_family : inductive Univ.puniverses * constr list -> inductive_family
+val dest_ind_family : inductive_family -> inductive Univ.puniverses * constr list
val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family
val liftn_inductive_family : int -> int -> inductive_family -> inductive_family
val lift_inductive_family : int -> inductive_family -> inductive_family
@@ -195,7 +195,7 @@ i*)
(********************)
val type_of_inductive_knowing_conclusion :
- env -> evar_map -> Inductive.mind_specif puniverses -> EConstr.types -> evar_map * EConstr.types
+ env -> evar_map -> Inductive.mind_specif Univ.puniverses -> EConstr.types -> evar_map * EConstr.types
(********************)
val control_only_guard : env -> types -> unit
diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml
index bc563b46dc..f0cb8fd1f2 100644
--- a/pretyping/miscops.ml
+++ b/pretyping/miscops.ml
@@ -30,7 +30,8 @@ let smartmap_cast_type f c =
let glob_sort_eq g1 g2 = match g1, g2 with
| GProp, GProp -> true
| GSet, GSet -> true
-| GType l1, GType l2 -> List.equal (fun x y -> Names.Name.equal (snd x) (snd y)) l1 l2
+| GType l1, GType l2 ->
+ List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.eq_reference x y && Int.equal m n)) l1 l2
| _ -> false
let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index ce478ac202..7149d62a19 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -7,20 +7,19 @@
(************************************************************************)
open Names
-open Constr
open Environ
open EConstr
open Type_errors
type unification_error =
- | OccurCheck of existential_key * constr
+ | OccurCheck of Evar.t * constr
| NotClean of existential * env * constr (* Constr is a variable not in scope *)
| NotSameArgSize
| NotSameHead
| NoCanonicalStructure
| ConversionFailed of env * constr * constr (* Non convertible closed terms *)
- | MetaOccurInBody of existential_key
- | InstanceNotSameType of existential_key * env * types * types
+ | MetaOccurInBody of Evar.t
+ | InstanceNotSameType of Evar.t * env * types * types
| UnifUnivInconsistency of Univ.univ_inconsistency
| CannotSolveConstraint of Evd.evar_constraint * unification_error
| ProblemBeyondCapabilities
@@ -39,8 +38,8 @@ type pretype_error =
(* Type inference unification *)
| ActualTypeNotCoercible of unsafe_judgment * types * unification_error
(* Tactic unification *)
- | UnifOccurCheck of existential_key * constr
- | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option
+ | UnifOccurCheck of Evar.t * constr
+ | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option
| CannotUnify of constr * constr * unification_error option
| CannotUnifyLocal of constr * constr * constr
| CannotUnifyBindingType of constr * constr
@@ -57,7 +56,7 @@ type pretype_error =
| TypingError of type_error
| CannotUnifyOccurrences of subterm_unification_error
| UnsatisfiableConstraints of
- (existential_key * Evar_kinds.t) option * Evar.Set.t option
+ (Evar.t * Evar_kinds.t) option * Evar.Set.t option
exception PretypeError of env * Evd.evar_map * pretype_error
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index dab376ef07..430755ea04 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -15,14 +15,14 @@ open Type_errors
(** {6 The type of errors raised by the pretyper } *)
type unification_error =
- | OccurCheck of existential_key * constr
+ | OccurCheck of Evar.t * constr
| NotClean of existential * env * constr
| NotSameArgSize
| NotSameHead
| NoCanonicalStructure
| ConversionFailed of env * constr * constr
- | MetaOccurInBody of existential_key
- | InstanceNotSameType of existential_key * env * types * types
+ | MetaOccurInBody of Evar.t
+ | InstanceNotSameType of Evar.t * env * types * types
| UnifUnivInconsistency of Univ.univ_inconsistency
| CannotSolveConstraint of Evd.evar_constraint * unification_error
| ProblemBeyondCapabilities
@@ -41,8 +41,8 @@ type pretype_error =
(** Type inference unification *)
| ActualTypeNotCoercible of unsafe_judgment * types * unification_error
(** Tactic Unification *)
- | UnifOccurCheck of existential_key * constr
- | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option
+ | UnifOccurCheck of Evar.t * constr
+ | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option
| CannotUnify of constr * constr * unification_error option
| CannotUnifyLocal of constr * constr * constr
| CannotUnifyBindingType of constr * constr
@@ -59,7 +59,7 @@ type pretype_error =
| TypingError of type_error
| CannotUnifyOccurrences of subterm_unification_error
| UnsatisfiableConstraints of
- (existential_key * Evar_kinds.t) option * Evar.Set.t option
+ (Evar.t * Evar_kinds.t) option * Evar.Set.t option
(** unresolvable evar, connex component *)
exception PretypeError of env * Evd.evar_map * pretype_error
@@ -112,10 +112,10 @@ val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b
(** {6 Implicit arguments synthesis errors } *)
-val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b
+val error_occur_check : env -> Evd.evar_map -> Evar.t -> constr -> 'b
val error_unsolvable_implicit :
- ?loc:Loc.t -> env -> Evd.evar_map -> existential_key ->
+ ?loc:Loc.t -> env -> Evd.evar_map -> Evar.t ->
Evd.unsolvability_explanation option -> 'b
val error_cannot_unify : ?loc:Loc.t -> env -> Evd.evar_map ->
@@ -154,7 +154,7 @@ val error_var_not_found : ?loc:Loc.t -> Id.t -> 'b
(** {6 Typeclass errors } *)
-val unsatisfiable_constraints : env -> Evd.evar_map -> Evd.evar option ->
+val unsatisfiable_constraints : env -> Evd.evar_map -> Evar.t option ->
Evar.Set.t option -> 'a
val unsatisfiable_exception : exn -> bool
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index e3470b0f11..b930c5db83 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -177,53 +177,79 @@ let _ =
optwrite = (:=) Universes.set_minimization })
(** Miscellaneous interpretation functions *)
-let interp_universe_level_name ~anon_rigidity evd (loc, s) =
- match s with
- | Anonymous ->
- new_univ_level_variable ?loc anon_rigidity evd
- | Name s ->
- let s = Id.to_string s in
- let names, _ = Global.global_universe_names () in
- if CString.string_contains ~where:s ~what:"." then
- match List.rev (CString.split '.' s) with
- | [] -> anomaly (str"Invalid universe name " ++ str s ++ str".")
- | n :: dp ->
- let num = int_of_string n in
- let dp = DirPath.make (List.map Id.of_string dp) in
- let level = Univ.Level.make dp num in
- let evd =
- try Evd.add_global_univ evd level
- with UGraph.AlreadyDeclared -> evd
- in evd, level
- else
- try
- let level = Evd.universe_of_name evd s in
- evd, level
- with Not_found ->
- try
- let id = try Id.of_string s with _ -> raise Not_found in
- evd, snd (Id.Map.find id names)
- with Not_found ->
- if not (is_strict_universe_declarations ()) then
- new_univ_level_variable ?loc ~name:s univ_rigid evd
- else user_err ?loc ~hdr:"interp_universe_level_name"
- (Pp.(str "Undeclared universe: " ++ str s))
+
+let interp_known_universe_level evd r =
+ let loc, qid = Libnames.qualid_of_reference r in
+ try
+ match r with
+ | Libnames.Ident (loc, id) -> Evd.universe_of_name evd id
+ | Libnames.Qualid _ -> raise Not_found
+ with Not_found ->
+ let univ, k = Nametab.locate_universe qid in
+ Univ.Level.make univ k
+
+let interp_universe_level_name ~anon_rigidity evd r =
+ try evd, interp_known_universe_level evd r
+ with Not_found ->
+ match r with (* Qualified generated name *)
+ | Libnames.Qualid (loc, qid) ->
+ let dp, i = Libnames.repr_qualid qid in
+ let num =
+ try int_of_string (Id.to_string i)
+ with Failure _ ->
+ user_err ?loc ~hdr:"interp_universe_level_name"
+ (Pp.(str "Undeclared global universe: " ++ Libnames.pr_reference r))
+ in
+ let level = Univ.Level.make dp num in
+ let evd =
+ try Evd.add_global_univ evd level
+ with UGraph.AlreadyDeclared -> evd
+ in evd, level
+ | Libnames.Ident (loc, id) -> (* Undeclared *)
+ if not (is_strict_universe_declarations ()) then
+ new_univ_level_variable ?loc ~name:id univ_rigid evd
+ else user_err ?loc ~hdr:"interp_universe_level_name"
+ (Pp.(str "Undeclared universe: " ++ Id.print id))
let interp_universe ?loc evd = function
| [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in
evd, Univ.Universe.make l
| l ->
- List.fold_left (fun (evd, u) l ->
- (* [univ_flexible_alg] can produce algebraic universes in terms *)
- let evd', l = interp_universe_level_name ~anon_rigidity:univ_flexible evd l in
- (evd', Univ.sup u (Univ.Universe.make l)))
+ List.fold_left (fun (evd, u) l ->
+ let evd', u' =
+ match l with
+ | Some (l,n) ->
+ (* [univ_flexible_alg] can produce algebraic universes in terms *)
+ let anon_rigidity = univ_flexible in
+ let evd', l = interp_universe_level_name ~anon_rigidity evd l in
+ let u' = Univ.Universe.make l in
+ (match n with
+ | 0 -> evd', u'
+ | 1 -> evd', Univ.Universe.super u'
+ | _ ->
+ user_err ?loc ~hdr:"interp_universe"
+ (Pp.(str "Cannot interpret universe increment +" ++ int n)))
+ | None ->
+ let evd, l = new_univ_level_variable ?loc univ_flexible evd in
+ evd, Univ.Universe.make l
+ in (evd', Univ.sup u u'))
(evd, Univ.Universe.type0m) l
+let interp_known_level_info ?loc evd = function
+ | UUnknown | UAnonymous ->
+ user_err ?loc ~hdr:"interp_known_level_info"
+ (str "Anonymous universes not allowed here.")
+ | UNamed ref ->
+ try interp_known_universe_level evd ref
+ with Not_found ->
+ user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_reference ref)
+
let interp_level_info ?loc evd : Misctypes.level_info -> _ = function
- | None -> new_univ_level_variable ?loc univ_rigid evd
- | Some (loc,s) -> interp_universe_level_name ~anon_rigidity:univ_flexible evd (Loc.tag ?loc s)
+ | UUnknown -> new_univ_level_variable ?loc univ_rigid evd
+ | UAnonymous -> new_univ_level_variable ?loc univ_flexible evd
+ | UNamed s -> interp_universe_level_name ~anon_rigidity:univ_flexible evd s
-type inference_hook = env -> evar_map -> evar -> evar_map * constr
+type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr
type inference_flags = {
use_typeclasses : bool;
@@ -467,6 +493,11 @@ let pretype_id pretype k0 loc env evdref lvar id =
(*************************************************************************)
(* Main pretyping function *)
+let interp_known_glob_level ?loc evd = function
+ | GProp -> Univ.Level.prop
+ | GSet -> Univ.Level.set
+ | GType s -> interp_known_level_info ?loc evd s
+
let interp_glob_level ?loc evd : Misctypes.glob_level -> _ = function
| GProp -> evd, Univ.Level.prop
| GSet -> evd, Univ.Level.set
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index b2735ee22c..fe10be9e7c 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -20,6 +20,9 @@ open Glob_term
open Ltac_pretype
open Evardefine
+val interp_known_glob_level : ?loc:Loc.t -> Evd.evar_map ->
+ Misctypes.glob_level -> Univ.Level.t
+
(** An auxiliary function for searching for fixpoint guard indexes *)
val search_guard :
@@ -27,7 +30,7 @@ val search_guard :
type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
-type inference_hook = env -> evar_map -> evar -> evar_map * constr
+type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr
type inference_flags = {
use_typeclasses : bool;
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index 5dd6879d39..f8f086fad3 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -166,23 +166,6 @@ let retype ?(polyprop=true) sigma =
| Lambda _ | Fix _ | Construct _ -> retype_error NotAType
| _ -> decomp_sort env sigma (type_of env t)
- and sort_family_of env t =
- match EConstr.kind sigma t with
- | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s)
- | Sort _ -> InType
- | Prod (name,t,c2) ->
- let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in
- if not (is_impredicative_set env) &&
- s2 == InSet && sort_family_of env t == InType then InType else s2
- | App(f,args) when is_template_polymorphic env sigma f ->
- let t = type_of_global_reference_knowing_parameters env f args in
- Sorts.family (sort_of_atomic_type env sigma t args)
- | App(f,args) ->
- Sorts.family (sort_of_atomic_type env sigma (type_of env f) args)
- | Lambda _ | Fix _ | Construct _ -> retype_error NotAType
- | _ ->
- Sorts.family (decomp_sort env sigma (type_of env t))
-
and type_of_global_reference_knowing_parameters env c args =
let argtyps =
Array.map (fun c -> lazy (EConstr.to_constr sigma (type_of env c))) args in
@@ -198,15 +181,34 @@ let retype ?(polyprop=true) sigma =
EConstr.of_constr (type_of_constructor env (cstr, u))
| _ -> assert false
- in type_of, sort_of, sort_family_of,
- type_of_global_reference_knowing_parameters
+ in type_of, sort_of, type_of_global_reference_knowing_parameters
+
+let get_sort_family_of ?(truncation_style=false) ?(polyprop=true) env sigma t =
+ let type_of,_,type_of_global_reference_knowing_parameters = retype ~polyprop sigma in
+ let rec sort_family_of env t =
+ match EConstr.kind sigma t with
+ | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s)
+ | Sort _ -> InType
+ | Prod (name,t,c2) ->
+ let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in
+ if not (is_impredicative_set env) &&
+ s2 == InSet && sort_family_of env t == InType then InType else s2
+ | App(f,args) when is_template_polymorphic env sigma f ->
+ if truncation_style then InType else
+ let t = type_of_global_reference_knowing_parameters env f args in
+ Sorts.family (sort_of_atomic_type env sigma t args)
+ | App(f,args) ->
+ Sorts.family (sort_of_atomic_type env sigma (type_of env f) args)
+ | Lambda _ | Fix _ | Construct _ -> retype_error NotAType
+ | Ind _ when truncation_style && is_template_polymorphic env sigma t -> InType
+ | _ ->
+ Sorts.family (decomp_sort env sigma (type_of env t))
+ in sort_family_of env t
let get_sort_of ?(polyprop=true) env sigma t =
- let _,f,_,_ = retype ~polyprop sigma in anomaly_on_error (f env) t
-let get_sort_family_of ?(polyprop=true) env sigma c =
- let _,_,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) c
+ let _,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) t
let type_of_global_reference_knowing_parameters env sigma c args =
- let _,_,_,f = retype sigma in anomaly_on_error (f env c) args
+ let _,_,f = retype sigma in anomaly_on_error (f env c) args
let type_of_global_reference_knowing_conclusion env sigma c conclty =
match EConstr.kind sigma c with
@@ -232,7 +234,7 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty =
(* get_type_of polyprop lax env sigma c *)
let get_type_of ?(polyprop=true) ?(lax=false) env sigma c =
- let f,_,_,_ = retype ~polyprop sigma in
+ let f,_,_ = retype ~polyprop sigma in
if lax then f env c else anomaly_on_error (f env) c
(* Makes an unsafe judgment from a constr *)
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index af86df499c..6fdde90463 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -31,8 +31,11 @@ val get_type_of :
val get_sort_of :
?polyprop:bool -> env -> evar_map -> types -> Sorts.t
+(* When [truncation_style] is [true], tells if the type has been explicitly
+ truncated to Prop or (impredicative) Set; in particular, singleton type and
+ small inductive types, which have all eliminations to Type, are in Type *)
val get_sort_family_of :
- ?polyprop:bool -> env -> evar_map -> types -> Sorts.family
+ ?truncation_style:bool -> ?polyprop:bool -> env -> evar_map -> types -> Sorts.family
(** Makes an unsafe judgment from a constr *)
val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index d55b286fb4..2e213a51d7 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -521,7 +521,7 @@ let mark_unresolvable evi = mark_resolvability false evi
let mark_resolvable evi = mark_resolvability true evi
open Evar_kinds
-type evar_filter = existential_key -> Evar_kinds.t -> bool
+type evar_filter = Evar.t -> Evar_kinds.t -> bool
let all_evars _ _ = true
let all_goals _ = function VarInstance _ | GoalEvar -> true | _ -> false
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index 062d5cf356..618826f3d0 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -68,7 +68,7 @@ val class_info : global_reference -> typeclass (** raises a UserError if not a c
val dest_class_app : env -> evar_map -> EConstr.constr -> (typeclass * EConstr.EInstance.t) * constr list
(** Get the instantiated typeclass structure for a given universe instance. *)
-val typeclass_univ_instance : typeclass puniverses -> typeclass
+val typeclass_univ_instance : typeclass Univ.puniverses -> typeclass
(** Just return None if not a class *)
val class_of_constr : evar_map -> EConstr.constr -> (EConstr.rel_context * ((typeclass * EConstr.EInstance.t) * constr list)) option
@@ -83,11 +83,11 @@ val is_instance : global_reference -> bool
(** Returns the term and type for the given instance of the parameters and fields
of the type class. *)
-val instance_constructor : typeclass puniverses -> constr list ->
+val instance_constructor : typeclass Univ.puniverses -> constr list ->
constr option * types
(** Filter which evars to consider for resolution. *)
-type evar_filter = existential_key -> Evar_kinds.t -> bool
+type evar_filter = Evar.t -> Evar_kinds.t -> bool
val all_evars : evar_filter
val all_goals : evar_filter
val no_goals : evar_filter
diff --git a/pretyping/univdecls.ml b/pretyping/univdecls.ml
index 5576e33f46..3cf32d7ff0 100644
--- a/pretyping/univdecls.ml
+++ b/pretyping/univdecls.ml
@@ -6,9 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Pp
-open CErrors
open Names
+open CErrors
(** Local universes and constraints declarations *)
type universe_decl =
@@ -22,27 +21,16 @@ let default_univ_decl =
univdecl_extensible_constraints = true }
let interp_univ_constraints env evd cstrs =
- let open Misctypes in
- let u_of_id x =
- match x with
- | Misctypes.GProp -> Loc.tag Univ.Level.prop
- | GSet -> Loc.tag Univ.Level.set
- | GType None | GType (Some (_, Anonymous)) ->
- user_err ~hdr:"interp_constraint"
- (str "Cannot declare constraints on anonymous universes")
- | GType (Some (loc, Name id)) ->
- try loc, Evd.universe_of_name evd (Id.to_string id)
- with Not_found ->
- user_err ?loc ~hdr:"interp_constraint" (str "Undeclared universe " ++ Id.print id)
- in
let interp (evd,cstrs) (u, d, u') =
- let lloc, ul = u_of_id u and rloc, u'l = u_of_id u' in
+ let ul = Pretyping.interp_known_glob_level evd u in
+ let u'l = Pretyping.interp_known_glob_level evd u' in
let cstr = (ul,d,u'l) in
let cstrs' = Univ.Constraint.add cstr cstrs in
try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in
evd, cstrs'
with Univ.UniverseInconsistency e ->
- user_err ~hdr:"interp_constraint" (str "Universe inconsistency" (* TODO *))
+ user_err ~hdr:"interp_constraint"
+ (Univ.explain_universe_inconsistency (Termops.pr_evd_level evd) e)
in
List.fold_left interp (evd,Univ.Constraint.empty) cstrs
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-30 15:46:34 +0000