aboutsummaryrefslogtreecommitdiffhomepage
path: root/engine
diff options
context:
space:
mode:
Diffstat (limited to 'engine')
-rw-r--r--engine/eConstr.mli12
-rw-r--r--engine/evar_kinds.ml3
-rw-r--r--engine/evarutil.ml8
-rw-r--r--engine/evarutil.mli15
-rw-r--r--engine/evd.ml3
-rw-r--r--engine/evd.mli2
-rw-r--r--engine/namegen.ml12
-rw-r--r--engine/namegen.mli10
-rw-r--r--engine/termops.ml2
-rw-r--r--engine/termops.mli2
-rw-r--r--engine/uState.ml10
-rw-r--r--engine/uState.mli6
-rw-r--r--engine/univNames.ml21
-rw-r--r--engine/univNames.mli4
-rw-r--r--engine/universes.ml2
-rw-r--r--engine/universes.mli4
16 files changed, 78 insertions, 38 deletions
diff --git a/engine/eConstr.mli b/engine/eConstr.mli
index b0e834b2e..e9d3e782b 100644
--- a/engine/eConstr.mli
+++ b/engine/eConstr.mli
@@ -182,9 +182,21 @@ val destCoFix : Evd.evar_map -> t -> (t, t) pcofixpoint
val decompose_app : Evd.evar_map -> t -> t * t list
+(** Pops lambda abstractions until there are no more, skipping casts. *)
val decompose_lam : Evd.evar_map -> t -> (Name.t * t) list * t
+
+(** Pops lambda abstractions and letins until there are no more, skipping casts. *)
val decompose_lam_assum : Evd.evar_map -> t -> rel_context * t
+
+(** Pops [n] lambda abstractions, and pop letins only if needed to
+ expose enough lambdas, skipping casts.
+
+ @raise UserError if the term doesn't have enough lambdas. *)
val decompose_lam_n_assum : Evd.evar_map -> int -> t -> rel_context * t
+
+(** Pops [n] lambda abstractions and letins, skipping casts.
+
+ @raise UserError if the term doesn't have enough lambdas/letins. *)
val decompose_lam_n_decls : Evd.evar_map -> int -> t -> rel_context * t
val compose_lam : (Name.t * t) list -> t -> t
diff --git a/engine/evar_kinds.ml b/engine/evar_kinds.ml
index 6e123d642..12e2fda8e 100644
--- a/engine/evar_kinds.ml
+++ b/engine/evar_kinds.ml
@@ -9,7 +9,6 @@
(************************************************************************)
open Names
-open Misctypes
(** The kinds of existential variable *)
@@ -18,7 +17,7 @@ open Misctypes
type obligation_definition_status = Define of bool | Expand
-type matching_var_kind = FirstOrderPatVar of patvar | SecondOrderPatVar of patvar
+type matching_var_kind = FirstOrderPatVar of Id.t | SecondOrderPatVar of Id.t
type subevar_kind = Domain | Codomain | Body
diff --git a/engine/evarutil.ml b/engine/evarutil.ml
index 648f96035..82be4791f 100644
--- a/engine/evarutil.ml
+++ b/engine/evarutil.ml
@@ -436,12 +436,12 @@ let new_pure_evar_full evd evi =
(evd, evk)
let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) sign evd typ =
- let default_naming = Misctypes.IntroAnonymous in
+ let default_naming = IntroAnonymous in
let naming = Option.default default_naming naming in
let name = match naming with
- | Misctypes.IntroAnonymous -> None
- | Misctypes.IntroIdentifier id -> Some id
- | Misctypes.IntroFresh id ->
+ | IntroAnonymous -> None
+ | IntroIdentifier id -> Some id
+ | IntroFresh id ->
let has_name id = try let _ = Evd.evar_key id evd in true with Not_found -> false in
let id = Namegen.next_ident_away_from id has_name in
Some id
diff --git a/engine/evarutil.mli b/engine/evarutil.mli
index f83f262b4..c17f3d168 100644
--- a/engine/evarutil.mli
+++ b/engine/evarutil.mli
@@ -12,6 +12,7 @@ open Names
open Constr
open Evd
open Environ
+open Namegen
open EConstr
(** This module provides useful higher-level functions for evar manipulation. *)
@@ -27,7 +28,7 @@ val mk_new_meta : unit -> constr
val new_evar_from_context :
?src:Evar_kinds.t Loc.located -> ?filter:Filter.t ->
?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
+ ?naming:intro_pattern_naming_expr ->
?principal:bool ->
named_context_val -> evar_map -> types -> evar_map * EConstr.t
@@ -40,14 +41,14 @@ type naming_mode =
val new_evar :
?src:Evar_kinds.t Loc.located -> ?filter:Filter.t ->
?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
+ ?naming:intro_pattern_naming_expr ->
?principal:bool -> ?hypnaming:naming_mode ->
env -> evar_map -> types -> evar_map * EConstr.t
val new_pure_evar :
?src:Evar_kinds.t Loc.located -> ?filter:Filter.t ->
?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
+ ?naming:intro_pattern_naming_expr ->
?principal:bool ->
named_context_val -> evar_map -> types -> evar_map * Evar.t
@@ -57,7 +58,7 @@ val new_pure_evar_full : evar_map -> evar_info -> evar_map * Evar.t
them during type-checking and unification. *)
val new_type_evar :
?src:Evar_kinds.t Loc.located -> ?filter:Filter.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
+ ?naming:intro_pattern_naming_expr ->
?principal:bool -> ?hypnaming:naming_mode ->
env -> evar_map -> rigid ->
evar_map * (constr * Sorts.t)
@@ -79,7 +80,7 @@ val new_global : evar_map -> GlobRef.t -> evar_map * constr
as a telescope) is [sign] *)
val new_evar_instance :
?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list ->
- ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr ->
+ ?store:Store.t -> ?naming:intro_pattern_naming_expr ->
?principal:bool ->
named_context_val -> evar_map -> types ->
constr list -> evar_map * constr
@@ -262,13 +263,13 @@ val meta_counter_summary_tag : int Summary.Dyn.tag
val e_new_evar :
env -> evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t ->
?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
+ ?naming:intro_pattern_naming_expr ->
?principal:bool -> ?hypnaming:naming_mode -> types -> constr
[@@ocaml.deprecated "Use [Evarutil.new_evar]"]
val e_new_type_evar : env -> evar_map ref ->
?src:Evar_kinds.t Loc.located -> ?filter:Filter.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
+ ?naming:intro_pattern_naming_expr ->
?principal:bool -> ?hypnaming:naming_mode -> rigid -> constr * Sorts.t
[@@ocaml.deprecated "Use [Evarutil.new_type_evar]"]
diff --git a/engine/evd.ml b/engine/evd.ml
index 0c9c3a29b..f56f9662d 100644
--- a/engine/evd.ml
+++ b/engine/evd.ml
@@ -894,6 +894,9 @@ let check_eq evd s s' =
let check_leq evd s s' =
UGraph.check_leq (UState.ugraph evd.universes) s s'
+let check_constraints evd csts =
+ UGraph.check_constraints csts (UState.ugraph evd.universes)
+
let fix_undefined_variables evd =
{ evd with universes = UState.fix_undefined_variables evd.universes }
diff --git a/engine/evd.mli b/engine/evd.mli
index c40e925d8..405fcc403 100644
--- a/engine/evd.mli
+++ b/engine/evd.mli
@@ -552,6 +552,8 @@ val set_eq_instances : ?flex:bool ->
val check_eq : evar_map -> Univ.Universe.t -> Univ.Universe.t -> bool
val check_leq : evar_map -> Univ.Universe.t -> Univ.Universe.t -> bool
+val check_constraints : evar_map -> Univ.Constraint.t -> bool
+
val evar_universe_context : evar_map -> UState.t
val universe_context_set : evar_map -> Univ.ContextSet.t
val universe_subst : evar_map -> UnivSubst.universe_opt_subst
diff --git a/engine/namegen.ml b/engine/namegen.ml
index c069ec5a0..23c691139 100644
--- a/engine/namegen.ml
+++ b/engine/namegen.ml
@@ -29,6 +29,18 @@ open Context.Rel.Declaration
module RelDecl = Context.Rel.Declaration
+(** General evar naming using intro patterns *)
+type intro_pattern_naming_expr =
+ | IntroIdentifier of Id.t
+ | IntroFresh of Id.t
+ | IntroAnonymous
+
+let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with
+| IntroAnonymous, IntroAnonymous -> true
+| IntroIdentifier id1, IntroIdentifier id2 -> Names.Id.equal id1 id2
+| IntroFresh id1, IntroFresh id2 -> Names.Id.equal id1 id2
+| _ -> false
+
(**********************************************************************)
(* Conventional names *)
diff --git a/engine/namegen.mli b/engine/namegen.mli
index 1b70ef68d..a53c3a0d1 100644
--- a/engine/namegen.mli
+++ b/engine/namegen.mli
@@ -15,6 +15,16 @@ open Environ
open Evd
open EConstr
+(** General evar naming using intro patterns *)
+type intro_pattern_naming_expr =
+ | IntroIdentifier of Id.t
+ | IntroFresh of Id.t
+ | IntroAnonymous
+
+(** Equalities on [intro_pattern_naming] *)
+val intro_pattern_naming_eq :
+ intro_pattern_naming_expr -> intro_pattern_naming_expr -> bool
+
(*********************************************************************
Conventional default names *)
diff --git a/engine/termops.ml b/engine/termops.ml
index eacc36107..2db2e07bf 100644
--- a/engine/termops.ml
+++ b/engine/termops.ml
@@ -297,7 +297,7 @@ let has_no_evar sigma =
with Exit -> false
let pr_evd_level evd = UState.pr_uctx_level (Evd.evar_universe_context evd)
-let reference_of_level evd l = UState.reference_of_level (Evd.evar_universe_context evd) l
+let reference_of_level evd l = UState.qualid_of_level (Evd.evar_universe_context evd) l
let pr_evar_universe_context ctx =
let open UState in
diff --git a/engine/termops.mli b/engine/termops.mli
index 255494031..f9aa6ba63 100644
--- a/engine/termops.mli
+++ b/engine/termops.mli
@@ -282,7 +282,7 @@ val is_Prop : Evd.evar_map -> constr -> bool
val is_Set : Evd.evar_map -> constr -> bool
val is_Type : Evd.evar_map -> constr -> bool
-val reference_of_level : Evd.evar_map -> Univ.Level.t -> Libnames.reference
+val reference_of_level : Evd.evar_map -> Univ.Level.t -> Libnames.qualid
(** Combinators on judgments *)
diff --git a/engine/uState.ml b/engine/uState.ml
index 643c621fd..81ab3dd66 100644
--- a/engine/uState.ml
+++ b/engine/uState.ml
@@ -295,15 +295,15 @@ let constrain_variables diff ctx =
in
{ ctx with uctx_local = (univs, local); uctx_univ_variables = vars }
-let reference_of_level uctx =
+let qualid_of_level uctx =
let map, map_rev = uctx.uctx_names in
fun l ->
- try CAst.make @@ Libnames.Ident (Option.get (Univ.LMap.find l map_rev).uname)
+ try Libnames.qualid_of_ident (Option.get (Univ.LMap.find l map_rev).uname)
with Not_found | Option.IsNone ->
- UnivNames.reference_of_level l
+ UnivNames.qualid_of_level l
let pr_uctx_level uctx l =
- Libnames.pr_reference (reference_of_level uctx l)
+ Libnames.pr_qualid (qualid_of_level uctx l)
type ('a, 'b) gen_universe_decl = {
univdecl_instance : 'a; (* Declared universes *)
@@ -312,7 +312,7 @@ type ('a, 'b) gen_universe_decl = {
univdecl_extensible_constraints : bool (* Can new constraints be added *) }
type universe_decl =
- (Misctypes.lident list, Univ.Constraint.t) gen_universe_decl
+ (lident list, Univ.Constraint.t) gen_universe_decl
let default_univ_decl =
{ univdecl_instance = [];
diff --git a/engine/uState.mli b/engine/uState.mli
index e2f25642e..a59e61b89 100644
--- a/engine/uState.mli
+++ b/engine/uState.mli
@@ -26,7 +26,7 @@ val empty : t
val make : UGraph.t -> t
-val make_with_initial_binders : UGraph.t -> Misctypes.lident list -> t
+val make_with_initial_binders : UGraph.t -> lident list -> t
val is_empty : t -> bool
@@ -145,7 +145,7 @@ type ('a, 'b) gen_universe_decl = {
univdecl_extensible_constraints : bool (* Can new constraints be added *) }
type universe_decl =
- (Misctypes.lident list, Univ.Constraint.t) gen_universe_decl
+ (lident list, Univ.Constraint.t) gen_universe_decl
val default_univ_decl : universe_decl
@@ -171,6 +171,6 @@ val update_sigma_env : t -> Environ.env -> t
(** {5 Pretty-printing} *)
val pr_uctx_level : t -> Univ.Level.t -> Pp.t
-val reference_of_level : t -> Univ.Level.t -> Libnames.reference
+val qualid_of_level : t -> Univ.Level.t -> Libnames.qualid
val pr_weak : (Univ.Level.t -> Pp.t) -> t -> Pp.t
diff --git a/engine/univNames.ml b/engine/univNames.ml
index 6e59a7c9e..a68840174 100644
--- a/engine/univNames.ml
+++ b/engine/univNames.ml
@@ -14,18 +14,19 @@ open Globnames
open Nametab
-let reference_of_level l = CAst.make @@
+let qualid_of_level l =
match Level.name l with
| Some (d, n as na) ->
- let qid =
- try Nametab.shortest_qualid_of_universe na
- with Not_found ->
- let name = Id.of_string_soft (string_of_int n) in
- Libnames.make_qualid d name
- in Libnames.Qualid qid
- | None -> Libnames.Ident Id.(of_string_soft (Level.to_string l))
+ begin
+ try Nametab.shortest_qualid_of_universe na
+ with Not_found ->
+ let name = Id.of_string_soft (string_of_int n) in
+ Libnames.make_qualid d name
+ end
+ | None ->
+ Libnames.qualid_of_ident @@ Id.of_string_soft (Level.to_string l)
-let pr_with_global_universes l = Libnames.pr_reference (reference_of_level l)
+let pr_with_global_universes l = Libnames.pr_qualid (qualid_of_level l)
(** Global universe information outside the kernel, to handle
polymorphic universe names in sections that have to be discharged. *)
@@ -89,7 +90,7 @@ let register_universe_binders ref ubinders =
if not (Id.Map.is_empty ubinders)
then Lib.add_anonymous_leaf (ubinder_obj (ref,ubinders))
-type univ_name_list = Misctypes.lname list
+type univ_name_list = Names.lname list
let universe_binders_with_opt_names ref levels = function
| None -> universe_binders_of_global ref
diff --git a/engine/univNames.mli b/engine/univNames.mli
index e3bc3193d..837beac26 100644
--- a/engine/univNames.mli
+++ b/engine/univNames.mli
@@ -11,7 +11,7 @@
open Univ
val pr_with_global_universes : Level.t -> Pp.t
-val reference_of_level : Level.t -> Libnames.reference
+val qualid_of_level : Level.t -> Libnames.qualid
(** Global universe information outside the kernel, to handle
polymorphic universes in sections that have to be discharged. *)
@@ -29,7 +29,7 @@ val empty_binders : universe_binders
val register_universe_binders : Names.GlobRef.t -> universe_binders -> unit
val universe_binders_of_global : Names.GlobRef.t -> universe_binders
-type univ_name_list = Misctypes.lname list
+type univ_name_list = Names.lname list
(** [universe_binders_with_opt_names ref u l]
diff --git a/engine/universes.ml b/engine/universes.ml
index 70601987c..ee9668433 100644
--- a/engine/universes.ml
+++ b/engine/universes.ml
@@ -17,7 +17,7 @@ type universe_binders = UnivNames.universe_binders
type univ_name_list = UnivNames.univ_name_list
let pr_with_global_universes = UnivNames.pr_with_global_universes
-let reference_of_level = UnivNames.reference_of_level
+let reference_of_level = UnivNames.qualid_of_level
let add_global_universe = UnivNames.add_global_universe
diff --git a/engine/universes.mli b/engine/universes.mli
index 46ff33a47..29673de1e 100644
--- a/engine/universes.mli
+++ b/engine/universes.mli
@@ -22,8 +22,8 @@ open Univ
val pr_with_global_universes : Level.t -> Pp.t
[@@ocaml.deprecated "Use [UnivNames.pr_with_global_universes]"]
-val reference_of_level : Level.t -> Libnames.reference
-[@@ocaml.deprecated "Use [UnivNames.reference_of_level]"]
+val reference_of_level : Level.t -> Libnames.qualid
+[@@ocaml.deprecated "Use [UnivNames.qualid_of_level]"]
val add_global_universe : Level.t -> Decl_kinds.polymorphic -> unit
[@@ocaml.deprecated "Use [UnivNames.add_global_universe]"]
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-29 11:59:58 +0000