summaryrefslogtreecommitdiff
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/arguments_renaming.ml8
-rw-r--r--pretyping/arguments_renaming.mli6
-rw-r--r--pretyping/cases.ml333
-rw-r--r--pretyping/cases.mli17
-rw-r--r--pretyping/cbv.ml14
-rw-r--r--pretyping/cbv.mli2
-rw-r--r--pretyping/classops.ml6
-rw-r--r--pretyping/classops.mli3
-rw-r--r--pretyping/coercion.ml64
-rw-r--r--pretyping/constr_matching.ml39
-rw-r--r--pretyping/detyping.ml62
-rw-r--r--pretyping/detyping.mli3
-rw-r--r--pretyping/evarconv.ml227
-rw-r--r--pretyping/evarconv.mli3
-rw-r--r--pretyping/evardefine.ml207
-rw-r--r--pretyping/evardefine.mli46
-rw-r--r--pretyping/evarsolve.ml261
-rw-r--r--pretyping/evarsolve.mli11
-rw-r--r--pretyping/evarutil.ml872
-rw-r--r--pretyping/evarutil.mli255
-rw-r--r--pretyping/evd.ml1908
-rw-r--r--pretyping/evd.mli621
-rw-r--r--pretyping/find_subterm.ml26
-rw-r--r--pretyping/find_subterm.mli5
-rw-r--r--pretyping/glob_ops.ml94
-rw-r--r--pretyping/glob_ops.mli13
-rw-r--r--pretyping/indrec.ml156
-rw-r--r--pretyping/indrec.mli15
-rw-r--r--pretyping/inductiveops.ml133
-rw-r--r--pretyping/inductiveops.mli35
-rw-r--r--pretyping/locusops.ml6
-rw-r--r--pretyping/namegen.ml395
-rw-r--r--pretyping/namegen.mli102
-rw-r--r--pretyping/nativenorm.ml44
-rw-r--r--pretyping/nativenorm.mli1
-rw-r--r--pretyping/patternops.ml15
-rw-r--r--pretyping/patternops.mli1
-rw-r--r--pretyping/pretype_errors.ml7
-rw-r--r--pretyping/pretype_errors.mli1
-rw-r--r--pretyping/pretyping.ml512
-rw-r--r--pretyping/pretyping.mli27
-rw-r--r--pretyping/pretyping.mllib7
-rw-r--r--pretyping/program.ml48
-rw-r--r--pretyping/program.mli4
-rw-r--r--pretyping/recordops.ml53
-rw-r--r--pretyping/redops.ml14
-rw-r--r--pretyping/reductionops.ml403
-rw-r--r--pretyping/reductionops.mli70
-rw-r--r--pretyping/retyping.ml32
-rw-r--r--pretyping/retyping.mli5
-rw-r--r--pretyping/tacred.ml101
-rw-r--r--pretyping/tacred.mli5
-rw-r--r--pretyping/termops.ml1026
-rw-r--r--pretyping/termops.mli248
-rw-r--r--pretyping/typeclasses.ml135
-rw-r--r--pretyping/typeclasses.mli30
-rw-r--r--pretyping/typeclasses_errors.ml3
-rw-r--r--pretyping/typeclasses_errors.mli5
-rw-r--r--pretyping/typing.ml56
-rw-r--r--pretyping/typing.mli11
-rw-r--r--pretyping/unification.ml214
-rw-r--r--pretyping/unification.mli12
-rw-r--r--pretyping/vnorm.ml30
-rw-r--r--pretyping/vnorm.mli1
64 files changed, 2201 insertions, 6868 deletions
diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml
index ca1d0b7f..e18aece0 100644
--- a/pretyping/arguments_renaming.ml
+++ b/pretyping/arguments_renaming.ml
@@ -16,12 +16,12 @@ open Libobject
(*i*)
let name_table =
- Summary.ref (Refmap.empty : Name.t list list Refmap.t)
+ Summary.ref (Refmap.empty : Name.t list Refmap.t)
~name:"rename-arguments"
type req =
| ReqLocal
- | ReqGlobal of global_reference * Name.t list list
+ | ReqGlobal of global_reference * Name.t list
let load_rename_args _ (_, (_, (r, names))) =
name_table := Refmap.add r names !name_table
@@ -49,7 +49,7 @@ let discharge_rename_args = function
let vars,_,_ = section_segment_of_reference c in
let c' = pop_global_reference c in
let var_names = List.map (fun (id, _,_,_) -> Name id) vars in
- let names' = List.map (fun l -> var_names @ l) names in
+ let names' = var_names @ names in
Some (ReqGlobal (c', names), (c', names'))
with Not_found -> Some req)
| _ -> None
@@ -83,7 +83,7 @@ let rec rename_prod c = function
| _ -> c
let rename_type ty ref =
- try rename_prod ty (List.hd (arguments_names ref))
+ try rename_prod ty (arguments_names ref)
with Not_found -> ty
let rename_type_of_constant env c =
diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli
index a3340550..e123e778 100644
--- a/pretyping/arguments_renaming.mli
+++ b/pretyping/arguments_renaming.mli
@@ -11,10 +11,10 @@ open Globnames
open Environ
open Term
-val rename_arguments : bool -> global_reference -> Name.t list list -> unit
+val rename_arguments : bool -> global_reference -> Name.t list -> unit
-(** [Not_found] is raised is no names are defined for [r] *)
-val arguments_names : global_reference -> Name.t list list
+(** [Not_found] is raised if no names are defined for [r] *)
+val arguments_names : global_reference -> Name.t list
val rename_type_of_constant : env -> pconstant -> types
val rename_type_of_inductive : env -> pinductive -> types
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 3d6fa38d..6e4d7270 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -7,13 +7,12 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Nameops
open Term
open Vars
-open Context
open Termops
open Namegen
open Declarations
@@ -26,9 +25,12 @@ open Glob_ops
open Retyping
open Pretype_errors
open Evarutil
+open Evardefine
open Evarsolve
open Evarconv
open Evd
+open Sigma.Notations
+open Context.Rel.Declaration
(* Pattern-matching errors *)
@@ -60,13 +62,15 @@ let error_wrong_numarg_constructor_loc loc env c n =
let error_wrong_numarg_inductive_loc loc env c n =
raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargInductive(c,n))
-let rec list_try_compile f = function
- | [a] -> f a
- | [] -> anomaly (str "try_find_f")
+let list_try_compile f l =
+ let rec aux errors = function
+ | [] -> if errors = [] then anomaly (str "try_find_f") else iraise (List.last errors)
| h::t ->
try f h
- with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ ->
- list_try_compile f t
+ with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ as e ->
+ let e = CErrors.push e in
+ aux (e::errors) t in
+ aux [] l
let force_name =
let nx = Name default_dependent_ident in function Anonymous -> nx | na -> na
@@ -131,7 +135,7 @@ type tomatch_status =
| Pushed of (bool*((constr * tomatch_type) * int list * Name.t))
| Alias of (bool*(Name.t * constr * (constr * types)))
| NonDepAlias
- | Abstract of int * rel_declaration
+ | Abstract of int * Context.Rel.Declaration.t
type tomatch_stack = tomatch_status list
@@ -273,13 +277,13 @@ let inductive_template evdref env tmloc ind =
| None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in
let (_,evarl,_) =
List.fold_right
- (fun (na,b,ty) (subst,evarl,n) ->
- match b with
- | None ->
+ (fun decl (subst,evarl,n) ->
+ match decl with
+ | LocalAssum (na,ty) ->
let ty' = substl subst ty in
let e = e_new_evar env evdref ~src:(hole_source n) ty' in
(e::subst,e::evarl,n+1)
- | Some b ->
+ | LocalDef (na,b,ty) ->
(substl subst b::subst,evarl,n+1))
arsign ([],[],1) in
applist (mkIndU indu,List.rev evarl)
@@ -307,15 +311,15 @@ let binding_vars_of_inductive = function
| NotInd _ -> []
| IsInd (_,IndType(_,realargs),_) -> List.filter isRel realargs
-let extract_inductive_data env sigma (_,b,t) =
- match b with
- | None ->
+let extract_inductive_data env sigma decl =
+ match decl with
+ | LocalAssum (_,t) ->
let tmtyp =
try try_find_ind env sigma t None
with Not_found -> NotInd (None,t) in
let tmtypvars = binding_vars_of_inductive tmtyp in
(tmtyp,tmtypvars)
- | Some _ ->
+ | LocalDef (_,_,t) ->
(NotInd (None, t), [])
let unify_tomatch_with_patterns evdref env loc typ pats realnames =
@@ -428,7 +432,7 @@ let remove_current_pattern eqn =
let push_current_pattern (cur,ty) eqn =
match eqn.patterns with
| pat::pats ->
- let rhs_env = push_rel (alias_of_pat pat,Some cur,ty) eqn.rhs.rhs_env in
+ let rhs_env = push_rel (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in
{ eqn with
rhs = { eqn.rhs with rhs_env = rhs_env };
patterns = pats }
@@ -455,9 +459,9 @@ let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
exception NotAdjustable
let rec adjust_local_defs loc = function
- | (pat :: pats, (_,None,_) :: decls) ->
+ | (pat :: pats, LocalAssum _ :: decls) ->
pat :: adjust_local_defs loc (pats,decls)
- | (pats, (_,Some _,_) :: decls) ->
+ | (pats, LocalDef _ :: decls) ->
PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
| [], [] -> []
| _ -> raise NotAdjustable
@@ -529,9 +533,10 @@ let dependencies_in_pure_rhs nargs eqns =
let deps_columns = matrix_transpose deps_rows in
List.map (List.exists (fun x -> x)) deps_columns
-let dependent_decl a = function
- | (na,None,t) -> dependent a t
- | (na,Some c,t) -> dependent a t || dependent a c
+let dependent_decl a =
+ function
+ | LocalAssum (na,t) -> dependent a t
+ | LocalDef (na,c,t) -> dependent a t || dependent a c
let rec dep_in_tomatch n = function
| (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch n l
@@ -602,7 +607,7 @@ let relocate_index_tomatch n1 n2 =
NonDepAlias :: genrec depth rest
| Abstract (i,d) :: rest ->
let i = relocate_rel n1 n2 depth i in
- Abstract (i,map_rel_declaration (relocate_index n1 n2 depth) d)
+ Abstract (i, map_constr (relocate_index n1 n2 depth) d)
:: genrec (depth+1) rest in
genrec 0
@@ -635,7 +640,7 @@ let replace_tomatch n c =
| NonDepAlias :: rest ->
NonDepAlias :: replrec depth rest
| Abstract (i,d) :: rest ->
- Abstract (i,map_rel_declaration (replace_term n c depth) d)
+ Abstract (i, map_constr (replace_term n c depth) d)
:: replrec (depth+1) rest in
replrec 0
@@ -660,7 +665,7 @@ let rec liftn_tomatch_stack n depth = function
NonDepAlias :: liftn_tomatch_stack n depth rest
| Abstract (i,d)::rest ->
let i = if i<depth then i else i+n in
- Abstract (i,map_rel_declaration (liftn n depth) d)
+ Abstract (i, map_constr (liftn n depth) d)
::(liftn_tomatch_stack n (depth+1) rest)
let lift_tomatch_stack n = liftn_tomatch_stack n 1
@@ -696,7 +701,7 @@ let merge_name get_name obj = function
let merge_names get_name = List.map2 (merge_name get_name)
let get_names env sign eqns =
- let names1 = List.make (List.length sign) Anonymous in
+ let names1 = List.make (Context.Rel.length sign) Anonymous in
(* If any, we prefer names used in pats, from top to bottom *)
let names2,aliasname =
List.fold_right
@@ -714,7 +719,7 @@ let get_names env sign eqns =
(fun (l,avoid) d na ->
let na =
merge_name
- (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
+ (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env t na) avoid))
d na
in
(na::l,(out_name na)::avoid))
@@ -728,18 +733,16 @@ let get_names env sign eqns =
(* We now replace the names y1 .. yn y by the actual names *)
(* xi1 .. xin xi to be found in the i-th clause of the matrix *)
-let set_declaration_name x (_,c,t) = (x,c,t)
-
-let recover_initial_subpattern_names = List.map2 set_declaration_name
+let recover_initial_subpattern_names = List.map2 set_name
let recover_and_adjust_alias_names names sign =
let rec aux = function
| [],[] ->
[]
- | x::names, (_,None,t)::sign ->
- (x,(alias_of_pat x,None,t)) :: aux (names,sign)
- | names, (na,(Some _ as c),t)::sign ->
- (PatVar (Loc.ghost,na),(na,c,t)) :: aux (names,sign)
+ | x::names, LocalAssum (_,t)::sign ->
+ (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign)
+ | names, (LocalDef (na,_,_) as decl)::sign ->
+ (PatVar (Loc.ghost,na), decl) :: aux (names,sign)
| _ -> assert false
in
List.split (aux (names,sign))
@@ -754,11 +757,12 @@ let push_rels_eqn_with_names sign eqn =
let sign = recover_initial_subpattern_names subpatnames sign in
push_rels_eqn sign eqn
-let push_generalized_decl_eqn env n (na,c,t) eqn =
- let na = match na with
- | Anonymous -> Anonymous
- | Name id -> pi1 (Environ.lookup_rel n eqn.rhs.rhs_env) in
- push_rels_eqn [(na,c,t)] eqn
+let push_generalized_decl_eqn env n decl eqn =
+ match get_name decl with
+ | Anonymous ->
+ push_rels_eqn [decl] eqn
+ | Name _ ->
+ push_rels_eqn [set_name (get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn
let drop_alias_eqn eqn =
{ eqn with alias_stack = List.tl eqn.alias_stack }
@@ -766,7 +770,7 @@ let drop_alias_eqn eqn =
let push_alias_eqn alias eqn =
let aliasname = List.hd eqn.alias_stack in
let eqn = drop_alias_eqn eqn in
- let alias = set_declaration_name aliasname alias in
+ let alias = set_name aliasname alias in
push_rels_eqn [alias] eqn
(**********************************************************************)
@@ -837,10 +841,10 @@ let regeneralize_index_predicate n = map_predicate (relocate_index n 1) 0
let substnl_predicate sigma = map_predicate (substnl sigma)
(* This is parallel bindings *)
-let subst_predicate (args,copt) ccl tms =
+let subst_predicate (subst,copt) ccl tms =
let sigma = match copt with
- | None -> List.rev args
- | Some c -> c::(List.rev args) in
+ | None -> subst
+ | Some c -> c::subst in
substnl_predicate sigma 0 ccl tms
let specialize_predicate_var (cur,typ,dep) tms ccl =
@@ -921,7 +925,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl =
let tms = List.fold_right2 (fun par arg tomatch ->
match kind_of_term par with
| Rel i -> relocate_index_tomatch (i+n) (destRel arg) tomatch
- | _ -> tomatch) (realargs@[cur]) (extended_rel_list 0 sign)
+ | _ -> tomatch) (realargs@[cur]) (Context.Rel.to_extended_list 0 sign)
(lift_tomatch_stack n tms) in
(* Pred is already dependent in the current term to match (if *)
(* (na<>Anonymous) and its realargs; we just need to adjust it to *)
@@ -932,7 +936,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl =
in
let pred = extract_predicate ccl tms in
(* Build the predicate properly speaking *)
- let sign = List.map2 set_declaration_name (na::names) sign in
+ let sign = List.map2 set_name (na::names) sign in
it_mkLambda_or_LetIn_name env pred sign
(* [expand_arg] is used by [specialize_predicate]
@@ -1018,7 +1022,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl =
(* We prepare the substitution of X and x:I(X) *)
let realargsi =
if not (Int.equal nrealargs 0) then
- adjust_subst_to_rel_context arsign (Array.to_list cs.cs_concl_realargs)
+ subst_of_rel_context_instance arsign (Array.to_list cs.cs_concl_realargs)
else
[] in
let copti = match depna with
@@ -1118,14 +1122,14 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs =
let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with
| [], _ -> brs,tomatch,pred,[]
| n::deps, Abstract (i,d) :: tomatch ->
- let d = map_rel_declaration (nf_evar evd) d in
- let is_d = match d with (_, None, _) -> false | _ -> true in
+ let d = map_constr (nf_evar evd) d in
+ let is_d = match d with LocalAssum _ -> false | LocalDef _ -> true in
if is_d || List.exists (fun c -> dependent_decl (lift k c) d) tocheck
&& Array.exists (is_dependent_branch k) brs then
(* Dependency in the current term to match and its dependencies is real *)
let brs,tomatch,pred,inst = aux (k+1) brs tomatch pred (mkRel n::tocheck) deps in
let inst = match d with
- | (_, None, _) -> mkRel n :: inst
+ | LocalAssum _ -> mkRel n :: inst
| _ -> inst
in
brs, Abstract (i,d) :: tomatch, pred, inst
@@ -1187,12 +1191,13 @@ let group_equations pb ind current cstrs mat =
let rec generalize_problem names pb = function
| [] -> pb, []
| i::l ->
- let (na,b,t as d) = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
let pb',deps = generalize_problem names pb l in
- begin match (na, b) with
- | Anonymous, Some _ -> pb', deps
+ let d = map_constr (lift i) (Environ.lookup_rel i pb.env) in
+ begin match d with
+ | LocalDef (Anonymous,_,_) -> pb', deps
| _ ->
- let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *)
+ (* for better rendering *)
+ let d = map_type (whd_betaiota !(pb.evdref)) d in
let tomatch = lift_tomatch_stack 1 pb'.tomatch in
let tomatch = relocate_index_tomatch (i+1) 1 tomatch in
{ pb' with
@@ -1220,7 +1225,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
(* that had matched constructor C *)
let cs_args = const_info.cs_args in
let names,aliasname = get_names pb.env cs_args eqns in
- let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
+ let typs = List.map2 set_name names cs_args
+ in
(* We build the matrix obtained by expanding the matching on *)
(* "C x1..xn as x" followed by a residual matching on eqn into *)
@@ -1230,7 +1236,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
(* We adjust the terms to match in the context they will be once the *)
(* context [x1:T1,..,xn:Tn] will have been pushed on the current env *)
let typs' =
- List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 typs in
+ List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in
let extenv = push_rel_context typs pb.env in
@@ -1268,7 +1274,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
let typs' =
List.map2
- (fun (tm,(tmtyp,_),(na,_,_)) deps ->
+ (fun (tm, (tmtyp,_), decl) deps ->
+ let na = get_name decl in
let na = match curname, na with
| Name _, Anonymous -> curname
| Name _, Name _ -> na
@@ -1324,14 +1331,6 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
*)
-let mk_case pb (ci,pred,c,brs) =
- let mib = lookup_mind (fst ci.ci_ind) pb.env in
- match mib.mind_record with
- | Some (Some (_, cs, pbs)) ->
- Reduction.beta_appvect brs.(0)
- (Array.map (fun p -> mkProj (Projection.make p true, c)) cs)
- | _ -> mkCase (ci,pred,c,brs)
-
(**********************************************************************)
(* Main compiling descent *)
let rec compile pb =
@@ -1378,7 +1377,9 @@ and match_current pb (initial,tomatch) =
pred current indt (names,dep) tomatch in
let ci = make_case_info pb.env (fst mind) pb.casestyle in
let pred = nf_betaiota !(pb.evdref) pred in
- let case = mk_case pb (ci,pred,current,brvals) in
+ let case =
+ make_case_or_project pb.env indf ci pred current brvals
+ in
Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred;
{ uj_val = applist (case, inst);
uj_type = prod_applist typ inst }
@@ -1392,7 +1393,7 @@ and shift_problem ((current,t),_,na) pb =
let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in
let pb =
{ pb with
- env = push_rel (na,Some current,ty) pb.env;
+ env = push_rel (LocalDef (na,current,ty)) pb.env;
tomatch = tomatch;
pred = lift_predicate 1 pred tomatch;
history = pop_history pb.history;
@@ -1440,7 +1441,7 @@ and compile_generalization pb i d rest =
([false]). *)
and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest =
let f c t =
- let alias = (na,Some c,t) in
+ let alias = LocalDef (na,c,t) in
let pb =
{ pb with
env = push_rel alias pb.env;
@@ -1560,8 +1561,8 @@ let matx_of_eqns env eqns =
*)
let adjust_to_extended_env_and_remove_deps env extenv subst t =
- let n = rel_context_length (rel_context env) in
- let n' = rel_context_length (rel_context extenv) in
+ let n = Context.Rel.length (rel_context env) in
+ let n' = Context.Rel.length (rel_context extenv) in
(* We first remove the bindings that are dependently typed (they are
difficult to manage and it is not sure these are so useful in practice);
Notes:
@@ -1576,9 +1577,9 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t =
(* \--------------extenv------------/ *)
let (p, _, _) = lookup_rel_id x (rel_context extenv) in
let rec traverse_local_defs p =
- match pi2 (lookup_rel p extenv) with
- | Some c -> assert (isRel c); traverse_local_defs (p + destRel c)
- | None -> p in
+ match lookup_rel p extenv with
+ | LocalDef (_,c,_) -> assert (isRel c); traverse_local_defs (p + destRel c)
+ | LocalAssum _ -> p in
let p = traverse_local_defs p in
let u = lift (n' - n) u in
try Some (p, u, expand_vars_in_term extenv u)
@@ -1623,7 +1624,7 @@ let abstract_tycon loc env evdref subst tycon extenv t =
convertible subterms of the substitution *)
let rec aux (k,env,subst as x) t =
let t = whd_evar !evdref t in match kind_of_term t with
- | Rel n when pi2 (lookup_rel n env) != None -> t
+ | Rel n when is_local_def (lookup_rel n env) -> t
| Evar ev ->
let ty = get_type_of env !evdref t in
let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in
@@ -1659,7 +1660,8 @@ let abstract_tycon loc env evdref subst tycon extenv t =
List.map (fun a -> not (isRel a) || dependent a u
|| Int.Set.mem (destRel a) depvl) inst in
let named_filter =
- List.map (fun (id,_,_) -> dependent (mkVar id) u)
+ let open Context.Named.Declaration in
+ List.map (fun d -> dependent (mkVar (get_id d)) u)
(named_context extenv) in
let filter = Filter.make (rel_filter @ named_filter) in
let candidates = u :: List.map mkRel vl in
@@ -1673,8 +1675,8 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t =
| None ->
(* This is the situation we are building a return predicate and
we are in an impossible branch *)
- let n = rel_context_length (rel_context env) in
- let n' = rel_context_length (rel_context tycon_env) in
+ let n = Context.Rel.length (rel_context env) in
+ let n' = Context.Rel.length (rel_context tycon_env) in
let impossible_case_type, u =
e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(loc,Evar_kinds.ImpossibleCase) in
(lift (n'-n) impossible_case_type, mkSort u)
@@ -1702,7 +1704,7 @@ let build_inversion_problem loc env sigma tms t =
let id = next_name_away (named_hd env t Anonymous) avoid in
PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in
let rec reveal_pattern t (subst,avoid as acc) =
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ match kind_of_term (whd_all env sigma t) with
| Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc
| App (f,v) when isConstruct f ->
let cstr,u = destConstruct f in
@@ -1727,7 +1729,7 @@ let build_inversion_problem loc env sigma tms t =
List.rev_append patl patl',acc_sign,acc
| (t, NotInd (bo,typ)) :: tms ->
let pat,acc = make_patvar t acc in
- let d = (alias_of_pat pat,None,typ) in
+ let d = LocalAssum (alias_of_pat pat,typ) in
let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in
pat::patl,acc_sign,acc in
let avoid0 = ids_of_context env in
@@ -1744,7 +1746,7 @@ let build_inversion_problem loc env sigma tms t =
let n = List.length sign in
let decls =
- List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 sign in
+ List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 sign in
let pb_env = push_rel_context sign env in
let decls =
@@ -1754,17 +1756,17 @@ let build_inversion_problem loc env sigma tms t =
let dep_sign = find_dependencies_signature (List.make n true) decls in
let sub_tms =
- List.map2 (fun deps (tm,(tmtyp,_),(na,b,t)) ->
- let na = if List.is_empty deps then Anonymous else force_name na in
+ List.map2 (fun deps (tm, (tmtyp,_), decl) ->
+ let na = if List.is_empty deps then Anonymous else force_name (get_name decl) in
Pushed (true,((tm,tmtyp),deps,na)))
dep_sign decls in
let subst = List.map (fun (na,t) -> (na,lift n t)) subst in
- (* [eqn1] is the first clause of the auxiliary pattern-matching that
+ (* [main_eqn] is the main clause of the auxiliary pattern-matching that
serves as skeleton for the return type: [patl] is the
substructure of constructors extracted from the list of
constraints on the inductive types of the multiple terms matched
in the original pattern-matching problem Xi *)
- let eqn1 =
+ let main_eqn =
{ patterns = patl;
alias_stack = [];
eqn_loc = Loc.ghost;
@@ -1775,36 +1777,37 @@ let build_inversion_problem loc env sigma tms t =
rhs_vars = List.map fst subst;
avoid_ids = avoid;
it = Some (lift n t) } } in
- (* [eqn2] is the default clause of the auxiliary pattern-matching: it will
- catch the clauses of the original pattern-matching problem Xi whose
- type constraints are incompatible with the constraints on the
+ (* [catch_all] is a catch-all default clause of the auxiliary
+ pattern-matching, if needed: it will catch the clauses
+ of the original pattern-matching problem Xi whose type
+ constraints are incompatible with the constraints on the
inductive types of the multiple terms matched in Xi *)
- let eqn2 =
- { patterns = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) patl;
- alias_stack = [];
- eqn_loc = Loc.ghost;
- used = ref false;
- rhs = { rhs_env = pb_env;
- rhs_vars = [];
- avoid_ids = avoid0;
- it = None } } in
+ let catch_all_eqn =
+ if List.for_all (irrefutable env) patl then
+ (* No need for a catch all clause *)
+ []
+ else
+ [ { patterns = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) patl;
+ alias_stack = [];
+ eqn_loc = Loc.ghost;
+ used = ref false;
+ rhs = { rhs_env = pb_env;
+ rhs_vars = [];
+ avoid_ids = avoid0;
+ it = None } } ] in
(* [pb] is the auxiliary pattern-matching serving as skeleton for the
return type of the original problem Xi *)
- (* let sigma, s = Evd.new_sort_variable sigma in *)
-(*FIXME TRY *)
- (* let sigma, s = Evd.new_sort_variable univ_flexible sigma in *)
let s' = Retyping.get_sort_of env sigma t in
let sigma, s = Evd.new_sort_variable univ_flexible_alg sigma in
let sigma = Evd.set_leq_sort env sigma s' s in
let evdref = ref sigma in
- (* let ty = evd_comb1 (refresh_universes false) evdref ty in *)
let pb =
{ env = pb_env;
evdref = evdref;
pred = (*ty *) mkSort s;
tomatch = sub_tms;
history = start_history n;
- mat = [eqn1;eqn2];
+ mat = main_eqn :: catch_all_eqn;
caseloc = loc;
casestyle = RegularStyle;
typing_function = build_tycon loc env pb_env s subst} in
@@ -1816,7 +1819,8 @@ let build_inversion_problem loc env sigma tms t =
let build_initial_predicate arsign pred =
let rec buildrec n pred tmnames = function
| [] -> List.rev tmnames,pred
- | ((na,c,t)::realdecls)::lnames ->
+ | (decl::realdecls)::lnames ->
+ let na = get_name decl in
let n' = n + List.length realdecls in
buildrec (n'+1) pred (force_name na::tmnames) lnames
| _ -> assert false
@@ -1828,7 +1832,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
match tm with
| NotInd (bo,typ) ->
(match t with
- | None -> [na,Option.map (lift n) bo,lift n typ]
+ | None -> (match bo with
+ | None -> [LocalAssum (na, lift n typ)]
+ | Some b -> [LocalDef (na, lift n b, lift n typ)])
| Some (loc,_,_) ->
user_err_loc (loc,"",
str"Unexpected type annotation for a term of non inductive type."))
@@ -1846,8 +1852,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
anomaly (Pp.str "Ill-formed 'in' clause in cases");
List.rev realnal
| None -> List.make nrealargs_ctxt Anonymous in
- (na,None,build_dependent_inductive env0 indf')
- ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
+ LocalAssum (na, build_dependent_inductive env0 indf')
+ ::(List.map2 set_name realnal arsign) in
let rec buildrec n = function
| [],[] -> []
| (_,tm)::ltm, (_,x)::tmsign ->
@@ -1867,7 +1873,7 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon =
(* We put the tycon inside the arity signature, possibly discovering dependencies. *)
let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c =
- let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
+ let nar = List.fold_left (fun n sign -> Context.Rel.nhyps sign + n) 0 arsign in
let subst, len =
List.fold_right2 (fun (tm, tmtype) sign (subst, len) ->
let signlen = List.length sign in
@@ -1928,14 +1934,22 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c =
*)
let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
+ let refresh_tycon sigma t =
+ (** If we put the typing constraint in the term, it has to be
+ refreshed to preserve the invariant that no algebraic universe
+ can appear in the term. *)
+ refresh_universes ~status:Evd.univ_flexible ~onlyalg:true (Some true)
+ env sigma t
+ in
let preds =
match pred, tycon with
- (* No type annotation *)
+ (* No return clause *)
| None, Some t when not (noccur_with_meta 0 max_int t) ->
(* If the tycon is not closed w.r.t real variables, we try *)
(* two different strategies *)
- (* First strategy: we abstract the tycon wrt to the dependencies *)
- let p1 =
+ (* First strategy: we abstract the tycon wrt to the dependencies *)
+ let sigma, t = refresh_tycon sigma t in
+ let p1 =
prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in
(* Second strategy: we build an "inversion" predicate *)
let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in
@@ -1946,10 +1960,12 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
(* No dependent type constraint, or no constraints at all: *)
(* we use two strategies *)
let sigma,t = match tycon with
- | Some t -> sigma,t
+ | Some t -> refresh_tycon sigma t
| None ->
- let sigma, (t, _) =
+ let sigma = Sigma.Unsafe.of_evar_map sigma in
+ let Sigma ((t, _), sigma, _) =
new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in
+ let sigma = Sigma.to_evar_map sigma in
sigma, t
in
(* First strategy: we build an "inversion" predicate *)
@@ -1965,12 +1981,6 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
let evdref = ref sigma in
let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in
let sigma = !evdref in
- (* let sigma = Option.cata (fun tycon -> *)
- (* let na = Name (Id.of_string "x") in *)
- (* let tms = List.map (fun tm -> Pushed(tm,[],na)) tomatchs in *)
- (* let predinst = extract_predicate predcclj.uj_val tms in *)
- (* Coercion.inh_conv_coerce_to loc env !evdref predinst tycon) *)
- (* !evdref tycon in *)
let predccl = (j_nf_evar sigma predcclj).uj_val in
[sigma, predccl]
in
@@ -2016,7 +2026,9 @@ let mk_JMeq evdref typ x typ' y =
let mk_JMeq_refl evdref typ x =
papp evdref coq_JMeq_refl [| typ; x |]
-let hole = GHole (Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define true), Misctypes.IntroAnonymous, None)
+let hole =
+ GHole (Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false),
+ Misctypes.IntroAnonymous, None)
let constr_of_pat env evdref arsign pat avoid =
let rec typ env (ty, realargs) pat avoid =
@@ -2028,7 +2040,7 @@ let constr_of_pat env evdref arsign pat avoid =
let previd, id = prime avoid (Name (Id.of_string "wildcard")) in
Name id, id :: avoid
in
- (PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty,
+ (PatVar (l, name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty,
(List.map (fun x -> mkRel 1) realargs), 1, avoid)
| PatCstr (l,((_, i) as cstr),args,alias) ->
let cind = inductive_of_constructor cstr in
@@ -2045,7 +2057,8 @@ let constr_of_pat env evdref arsign pat avoid =
assert (Int.equal nb_args_constr (List.length args));
let patargs, args, sign, env, n, m, avoid =
List.fold_right2
- (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) ->
+ (fun decl ua (patargs, args, sign, env, n, m, avoid) ->
+ let t = get_type decl in
let pat', sign', arg', typ', argtypargs, n', avoid =
let liftt = liftn (List.length sign) (succ (List.length args)) t in
typ env (substl args liftt, []) ua avoid
@@ -2067,7 +2080,7 @@ let constr_of_pat env evdref arsign pat avoid =
Anonymous ->
pat', sign, app, apptype, realargs, n, avoid
| Name id ->
- let sign = (alias, None, lift m ty) :: sign in
+ let sign = LocalAssum (alias, lift m ty) :: sign in
let avoid = id :: avoid in
let sign, i, avoid =
try
@@ -2079,14 +2092,14 @@ let constr_of_pat env evdref arsign pat avoid =
(lift 1 app) (* aliased term *)
in
let neq = eq_id avoid id in
- (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid
+ LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, neq :: avoid
with Reduction.NotConvertible -> sign, 1, avoid
in
(* Mark the equality as a hole *)
pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
in
- let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in
- pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
+ let pat', sign, patc, patty, args, z, avoid = typ env (get_type (List.hd arsign), List.tl arsign) pat avoid in
+ pat', (sign, patc, (get_type (List.hd arsign), args), pat'), avoid
(* shadows functional version *)
@@ -2101,23 +2114,23 @@ match kind_of_term t with
| Rel 0 -> true
| _ -> false
-let rels_of_patsign l =
- List.map (fun ((na, b, t) as x) ->
- match b with
- | Some t' when is_topvar t' -> (na, None, t)
- | _ -> x) l
+let rels_of_patsign =
+ List.map (fun decl ->
+ match decl with
+ | LocalDef (na,t',t) when is_topvar t' -> LocalAssum (na,t)
+ | _ -> decl)
let vars_of_ctx ctx =
let _, y =
- List.fold_right (fun (na, b, t) (prev, vars) ->
- match b with
- | Some t' when is_topvar t' ->
+ List.fold_right (fun decl (prev, vars) ->
+ match decl with
+ | LocalDef (na,t',t) when is_topvar t' ->
prev,
(GApp (Loc.ghost,
(GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)),
[hole; GVar (Loc.ghost, prev)])) :: vars
| _ ->
- match na with
+ match get_name decl with
Anonymous -> invalid_arg "vars_of_ctx"
| Name n -> n, GVar (Loc.ghost, n) :: vars)
ctx (Id.of_string "vars_of_ctx_error", [])
@@ -2226,7 +2239,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
match ineqs with
| None -> [], arity
| Some ineqs ->
- [Anonymous, None, ineqs], lift 1 arity
+ [LocalAssum (Anonymous, ineqs)], lift 1 arity
in
let eqs_rels, arity = decompose_prod_n_assum neqs arity in
eqs_rels @ neqs_rels @ rhs_rels', arity
@@ -2237,7 +2250,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
let _btype = evd_comb1 (Typing.type_of env) evdref bbody in
let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in
- let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in
+ let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in
let branch =
let bref = GVar (Loc.ghost, branch_name) in
match vars_of_ctx rhs_rels with
@@ -2286,7 +2299,7 @@ let abstract_tomatch env tomatchs tycon =
(fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in
let name = next_ident_away (Id.of_string "filtered_var") names in
(mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev,
- (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx,
+ LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx,
name :: names, tycon)
([], [], [], tycon) tomatchs
in List.rev prev, ctx, tycon
@@ -2294,7 +2307,7 @@ let abstract_tomatch env tomatchs tycon =
let build_dependent_signature env evdref avoid tomatchs arsign =
let avoid = ref avoid in
let arsign = List.rev arsign in
- let allnames = List.rev_map (List.map pi1) arsign in
+ let allnames = List.rev_map (List.map get_name) arsign in
let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
let eqs, neqs, refls, slift, arsign' =
List.fold_left2
@@ -2310,11 +2323,15 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
(* Build the arity signature following the names in matched terms
as much as possible *)
let argsign = List.tl arsign in (* arguments in inverse application order *)
- let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *)
+ let app_decl = List.hd arsign in (* The matched argument *)
+ let appn = get_name app_decl in
+ let appt = get_type app_decl in
let argsign = List.rev argsign in (* arguments in application order *)
let env', nargeqs, argeqs, refl_args, slift, argsign' =
List.fold_left2
- (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) ->
+ (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl ->
+ let name = get_name decl in
+ let t = get_type decl in
let argt = Retyping.get_type_of env !evdref arg in
let eq, refl_arg =
if Reductionops.is_conv env !evdref argt t then
@@ -2332,16 +2349,16 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
let previd, id =
let name =
match kind_of_term arg with
- Rel n -> pi1 (lookup_rel n env)
+ Rel n -> get_name (lookup_rel n env)
| _ -> name
in
make_prime avoid name
in
(env, succ nargeqs,
- (Name (eq_id avoid previd), None, eq) :: argeqs,
+ (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs,
refl_arg :: refl_args,
pred slift,
- (Name id, b, t) :: argsign'))
+ set_name (Name id) decl :: argsign'))
(env, neqs, [], [], slift, []) args argsign
in
let eq = mk_JMeq evdref
@@ -2352,22 +2369,23 @@ let build_dependent_signature env evdref avoid tomatchs arsign =
in
let refl_eq = mk_JMeq_refl evdref ty tm in
let previd, id = make_prime avoid appn in
- (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs,
+ ((LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs,
succ nargeqs,
refl_eq :: refl_args,
pred slift,
- (((Name id, appb, appt) :: argsign') :: arsigns))
+ ((set_name (Name id) app_decl :: argsign') :: arsigns))
| _ -> (* Non dependent inductive or not inductive, just use a regular equality *)
- let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in
+ let decl = match arsign with [x] -> x | _ -> assert(false) in
+ let name = get_name decl in
let previd, id = make_prime avoid name in
- let arsign' = (Name id, b, typ) in
+ let arsign' = set_name (Name id) decl in
let tomatch_ty = type_of_tomatch ty in
let eq =
mk_eq evdref (lift nar tomatch_ty)
(mkRel slift) (lift nar tm)
in
- ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs,
+ ([LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs,
(mk_eq_refl evdref tomatch_ty tm) :: refl_args,
pred slift, (arsign' :: []) :: arsigns))
([], 0, [], nar, []) tomatchs arsign
@@ -2412,7 +2430,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
match tycon' with
| None -> let ev = mkExistential env evdref in ev, ev
| Some t ->
- let pred =
+ let pred =
match prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t with
| Some (evd, pred) -> evdref := evd; pred
| None ->
@@ -2441,7 +2459,9 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
(* We push the initial terms to match and push their alias to rhs' envs *)
(* names of aliases will be recovered from patterns (hence Anonymous here) *)
- let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in
+ let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t)
+ | NotInd (Some b, t) -> LocalDef (na,b,t)
+ | IsInd (typ,_,_) -> LocalAssum (na,typ) in
let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in
let typs =
@@ -2489,11 +2509,11 @@ let compile_program_cases loc style (typing_function, evdref) tycon env
(* Main entry of the matching compilation *)
let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) =
- if predopt == None && Flags.is_program_mode () then
- compile_program_cases loc style (typing_fun, evdref)
+ if predopt == None && Flags.is_program_mode () && Program.is_program_cases () then
+ compile_program_cases loc style (typing_fun, evdref)
tycon env (predopt, tomatchl, eqns)
else
-
+
(* We build the matrix of patterns and right-hand side *)
let matx = matx_of_eqns env eqns in
@@ -2514,7 +2534,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
(* names of aliases will be recovered from patterns (hence Anonymous *)
(* here) *)
- let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in
+ let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t)
+ | NotInd (Some b,t) -> LocalDef (na,b,t)
+ | IsInd (typ,_,_) -> LocalAssum (na,typ) in
let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in
let typs =
@@ -2553,6 +2575,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
typing_function = typing_fun } in
let j = compile pb in
+
+ (* We coerce to the tycon (if an elim predicate was provided) *)
+ let j = inh_conv_coerce_to_tycon loc env myevdref j tycon in
evdref := !myevdref;
j in
@@ -2563,6 +2588,4 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
(* We check for unused patterns *)
List.iter (check_unused_pattern env) matx;
- (* We coerce to the tycon (if an elim predicate was provided) *)
- inh_conv_coerce_to_tycon loc env evdref j tycon
-
+ j
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index ab00aa16..ee4148de 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -8,7 +8,6 @@
open Names
open Term
-open Context
open Evd
open Environ
open Inductiveops
@@ -33,6 +32,8 @@ val error_wrong_numarg_constructor_loc : Loc.t -> env -> constructor -> int -> '
val error_wrong_numarg_inductive_loc : Loc.t -> env -> inductive -> int -> 'a
+val irrefutable : env -> cases_pattern -> bool
+
(** {6 Compilation primitive. } *)
val compile_cases :
@@ -45,11 +46,11 @@ val compile_cases :
val constr_of_pat :
Environ.env ->
Evd.evar_map ref ->
- rel_declaration list ->
+ Context.Rel.Declaration.t list ->
Glob_term.cases_pattern ->
Names.Id.t list ->
Glob_term.cases_pattern *
- (rel_declaration list * Term.constr *
+ (Context.Rel.Declaration.t list * Term.constr *
(Term.types * Term.constr list) * Glob_term.cases_pattern) *
Names.Id.t list
@@ -83,7 +84,7 @@ type tomatch_status =
| Pushed of (bool*((constr * tomatch_type) * int list * Name.t))
| Alias of (bool * (Name.t * constr * (constr * types)))
| NonDepAlias
- | Abstract of int * rel_declaration
+ | Abstract of int * Context.Rel.Declaration.t
type tomatch_stack = tomatch_status list
@@ -113,11 +114,11 @@ val compile : 'a pattern_matching_problem -> Environ.unsafe_judgment
val prepare_predicate : Loc.t ->
(Evarutil.type_constraint ->
- Environ.env -> Evd.evar_map ref -> 'a -> Environ.unsafe_judgment) ->
+ Environ.env -> Evd.evar_map ref -> glob_constr -> Environ.unsafe_judgment) ->
Environ.env ->
Evd.evar_map ->
(Term.types * tomatch_type) list ->
- Context.rel_context list ->
+ Context.Rel.t list ->
Constr.constr option ->
- 'a option -> (Evd.evar_map * Names.name list * Term.constr) list
-
+ glob_constr option ->
+ (Evd.evar_map * Names.name list * Term.constr) list
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index 43062a0e..84bf849e 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -10,7 +10,7 @@ open Util
open Names
open Term
open Vars
-open Closure
+open CClosure
open Esubst
(**** Call by value reduction ****)
@@ -156,7 +156,7 @@ let strip_appl head stack =
(* Tests if fixpoint reduction is possible. *)
let fixp_reducible flgs ((reci,i),_) stk =
- if red_set flgs fIOTA then
+ if red_set flgs fFIX then
match stk with
| APP(appl,_) ->
Array.length appl > reci.(i) &&
@@ -168,7 +168,7 @@ let fixp_reducible flgs ((reci,i),_) stk =
false
let cofixp_reducible flgs _ stk =
- if red_set flgs fIOTA then
+ if red_set flgs fCOFIX then
match stk with
| (CASE _ | APP(_,CASE _)) -> true
| _ -> false
@@ -296,21 +296,21 @@ and cbv_stack_value info env = function
(* constructor in a Case -> IOTA *)
| (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,ci,env,stk)))
- when red_set (info_flags info) fIOTA ->
+ when red_set (info_flags info) fMATCH ->
let cargs =
Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in
cbv_stack_term info (stack_app cargs stk) env br.(n-1)
(* constructor of arity 0 in a Case -> IOTA *)
| (CONSTR(((_,n),u),[||]), CASE(_,br,_,env,stk))
- when red_set (info_flags info) fIOTA ->
+ when red_set (info_flags info) fMATCH ->
cbv_stack_term info stk env br.(n-1)
(* constructor in a Projection -> IOTA *)
| (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,pi,stk)))
- when red_set (info_flags info) fIOTA && Projection.unfolded p ->
+ when red_set (info_flags info) fMATCH && Projection.unfolded p ->
let arg = args.(pi.Declarations.proj_npars + pi.Declarations.proj_arg) in
- cbv_stack_value info env (arg, stk)
+ cbv_stack_value info env (strip_appl arg stk)
(* may be reduced later by application *)
| (FIXP(fix,env,[||]), APP(appl,TOP)) -> FIXP(fix,env,appl)
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index de37d1fc..87a03abb 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.mli
@@ -9,7 +9,7 @@
open Names
open Term
open Environ
-open Closure
+open CClosure
open Esubst
(***********************************************************************
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index ece92b66..4f265e76 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Pp
open Flags
@@ -297,7 +297,7 @@ let lookup_path_to_sort_from env sigma s =
let get_coercion_constructor env coe =
let c, _ =
- Reductionops.whd_betadeltaiota_stack env Evd.empty coe.coe_value
+ Reductionops.whd_all_stack env Evd.empty coe.coe_value
in
match kind_of_term c with
| Construct (cstr,u) ->
@@ -387,7 +387,7 @@ let add_coercion_in_graph (ic,source,target) =
end;
let is_ambig = match !ambig_paths with [] -> false | _ -> true in
if is_ambig && is_verbose () then
- msg_warning (message_ambig !ambig_paths)
+ Feedback.msg_info (message_ambig !ambig_paths)
type coercion = {
coercion_type : coe_typ;
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index cf88be62..d509739c 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -26,6 +26,9 @@ val cl_typ_eq : cl_typ -> cl_typ -> bool
val subst_cl_typ : substitution -> cl_typ -> cl_typ
+(** Comparison of [cl_typ] *)
+val cl_typ_ord : cl_typ -> cl_typ -> int
+
(** This is the type of infos for declared classes *)
type cl_info_typ = {
cl_param : int }
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 489a311b..913e80f3 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -14,7 +14,7 @@
Corbineau, Feb 2008 *)
(* Turned into an abstract compilation unit by Matthieu Sozeau, March 2006 *)
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -63,7 +63,7 @@ let apply_coercion_args env evd check isproj argl funj =
{ uj_val = applist (j_val funj,argl);
uj_type = typ }
| h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *)
- match kind_of_term (whd_betadeltaiota env evd typ) with
+ match kind_of_term (whd_all env evd typ) with
| Prod (_,c1,c2) ->
if check && not (e_cumul env evdref (Retyping.get_type_of env evd h) c1) then
raise NoCoercion;
@@ -90,8 +90,9 @@ let inh_pattern_coerce_to loc env pat ind1 ind2 =
open Program
-let make_existential loc ?(opaque = Evar_kinds.Define true) env evdref c =
- Evarutil.e_new_evar env evdref ~src:(loc, Evar_kinds.QuestionMark opaque) c
+let make_existential loc ?(opaque = not (get_proofs_transparency ())) env evdref c =
+ let src = (loc, Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in
+ Evarutil.e_new_evar env evdref ~src c
let app_opt env evdref f t =
whd_betaiota !evdref (app_opt f t)
@@ -115,7 +116,7 @@ let disc_subset x =
exception NoSubtacCoercion
-let hnf env evd c = whd_betadeltaiota env evd c
+let hnf env evd c = whd_all env evd c
let hnf_nodelta env evd c = whd_betaiota evd c
let lift_args n sign =
@@ -129,7 +130,7 @@ let mu env evdref t =
let rec aux v =
let v' = hnf env !evdref v in
match disc_subset v' with
- Some (u, p) ->
+ | Some (u, p) ->
let f, ct = aux u in
let p = hnf_nodelta env !evdref p in
(Some (fun x ->
@@ -142,6 +143,7 @@ let mu env evdref t =
and coerce loc env evdref (x : Term.constr) (y : Term.constr)
: (Term.constr -> Term.constr) option
=
+ let open Context.Rel.Declaration in
let rec coerce_unify env x y =
let x = hnf env !evdref x and y = hnf env !evdref y in
try
@@ -151,8 +153,9 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
and coerce' env x y : (Term.constr -> Term.constr) option =
let subco () = subset_coerce env evdref x y in
let dest_prod c =
+ let open Context.Rel.Declaration in
match Reductionops.splay_prod_n env ( !evdref) 1 c with
- | [(na,b,t)], c -> (na,t), c
+ | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na,t), c
| _ -> raise NoSubtacCoercion
in
let coerce_application typ typ' c c' l l' =
@@ -187,9 +190,9 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
(subst1 hdy restT') (succ i) (fun x -> eq_app (co x))
else Some (fun x ->
let term = co x in
- Typing.solve_evars env evdref term)
+ Typing.e_solve_evars env evdref term)
in
- if isEvar c || isEvar c' then
+ if isEvar c || isEvar c' || not (Program.is_program_generalized_coercion ()) then
(* Second-order unification needed. *)
raise NoSubtacCoercion;
aux [] typ typ' 0 (fun x -> x)
@@ -205,7 +208,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
let name' =
Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.ids_of_context env))
in
- let env' = push_rel (name', None, a') env in
+ let env' = push_rel (LocalAssum (name', a')) env in
let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
(* env, x : a' |- c1 : lift 1 a' > lift 1 a *)
let coec1 = app_opt env' evdref c1 (mkRel 1) in
@@ -241,9 +244,8 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
let remove_head a c =
match kind_of_term c with
| Lambda (n, t, t') -> c, t'
- (*| Prod (n, t, t') -> t'*)
| Evar (k, args) ->
- let (evs, t) = Evarutil.define_evar_as_lambda env !evdref (k,args) in
+ let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in
evdref := evs;
let (n, dom, rng) = destLambda t in
let dom = whd_evar !evdref dom in
@@ -255,7 +257,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
| _ -> raise NoSubtacCoercion
in
let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in
- let env' = push_rel (Name Namegen.default_dependent_ident, None, a) env in
+ let env' = push_rel (LocalAssum (Name Namegen.default_dependent_ident, a)) env in
let c2 = coerce_unify env' b b' in
match c1, c2 with
| None, None -> None
@@ -278,7 +280,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
let c1 = coerce_unify env a a' in
let c2 = coerce_unify env b b' in
match c1, c2 with
- None, None -> None
+ | None, None -> None
| _, _ ->
Some
(fun x ->
@@ -297,9 +299,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
with NoSubtacCoercion ->
let typ = Typing.unsafe_type_of env evm c in
let typ' = Typing.unsafe_type_of env evm c' in
- (* if not (is_arity env evm typ) then *)
coerce_application typ typ' c c' l l')
- (* else subco () *)
else
subco ()
| x, y when Constr.equal c c' ->
@@ -307,9 +307,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
let evm = !evdref in
let lam_type = Typing.unsafe_type_of env evm c in
let lam_type' = Typing.unsafe_type_of env evm c' in
- (* if not (is_arity env evm lam_type) then ( *)
coerce_application lam_type lam_type' c c' l l'
- (* ) else subco () *)
else subco ()
| _ -> subco ())
| _, _ -> subco ()
@@ -335,10 +333,17 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr)
raise NoSubtacCoercion
in coerce_unify env x y
+let app_coercion env evdref coercion v =
+ match coercion with
+ | None -> v
+ | Some f ->
+ let v' = Typing.e_solve_evars env evdref (f v) in
+ whd_betaiota !evdref v'
+
let coerce_itf loc env evd v t c1 =
let evdref = ref evd in
let coercion = coerce loc env evdref t c1 in
- let t = Option.map (app_opt env evdref coercion) v in
+ let t = Option.map (app_coercion env evdref coercion) v in
!evdref, t
let saturate_evd env evd =
@@ -365,15 +370,15 @@ let apply_coercion env sigma p hj typ_cl =
(hj,typ_cl,sigma) p
in evd, j
with NoCoercion as e -> raise e
- | e when Errors.noncritical e -> anomaly (Pp.str "apply_coercion")
+ | e when CErrors.noncritical e -> anomaly (Pp.str "apply_coercion")
(* Try to coerce to a funclass; raise NoCoercion if not possible *)
let inh_app_fun_core env evd j =
- let t = whd_betadeltaiota env evd j.uj_type in
+ let t = whd_all env evd j.uj_type in
match kind_of_term t with
| Prod (_,_,_) -> (evd,j)
| Evar ev ->
- let (evd',t) = define_evar_as_product evd ev in
+ let (evd',t) = Evardefine.define_evar_as_product evd ev in
(evd',{ uj_val = j.uj_val; uj_type = t })
| _ ->
try let t,p =
@@ -410,11 +415,11 @@ let inh_tosort_force loc env evd j =
error_not_a_type_loc loc env evd j
let inh_coerce_to_sort loc env evd j =
- let typ = whd_betadeltaiota env evd j.uj_type in
+ let typ = whd_all env evd j.uj_type in
match kind_of_term typ with
| Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s })
| Evar ev when not (is_defined evd (fst ev)) ->
- let (evd',s) = define_evar_as_sort env evd ev in
+ let (evd',s) = Evardefine.define_evar_as_sort env evd ev in
(evd',{ utj_val = j.uj_val; utj_type = s })
| _ ->
inh_tosort_force loc env evd j
@@ -424,7 +429,7 @@ let inh_coerce_to_base loc env evd j =
let evdref = ref evd in
let ct, typ' = mu env evdref j.uj_type in
let res =
- { uj_val = app_opt env evdref ct j.uj_val;
+ { uj_val = app_coercion env evdref ct j.uj_val;
uj_type = typ' }
in !evdref, res
else (evd, j)
@@ -462,8 +467,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
try inh_coerce_to_fail env evd rigidonly v t c1
with NoCoercion ->
match
- kind_of_term (whd_betadeltaiota env evd t),
- kind_of_term (whd_betadeltaiota env evd c1)
+ kind_of_term (whd_all env evd t),
+ kind_of_term (whd_all env evd c1)
with
| Prod (name,t1,t2), Prod (_,u1,u2) ->
(* Conversion did not work, we may succeed with a coercion. *)
@@ -475,7 +480,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
let name = match name with
| Anonymous -> Name Namegen.default_dependent_ident
| _ -> name in
- let env1 = push_rel (name,None,u1) env in
+ let open Context.Rel.Declaration in
+ let env1 = push_rel (LocalAssum (name,u1)) env in
let (evd', v1) =
inh_conv_coerce_to_fail loc env1 evd rigidonly
(Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
@@ -508,7 +514,7 @@ let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t =
error_actual_type_loc loc env best_failed_evd cj t e
else
inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t
- with NoCoercionNoUnifier (best_failed_evd,e) ->
+ with NoCoercionNoUnifier (_evd,_error) ->
error_actual_type_loc loc env best_failed_evd cj t e
in
let val' = match val' with Some v -> v | None -> assert(false) in
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index ee3c43d8..886a9826 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -8,7 +8,7 @@
(*i*)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Globnames
@@ -17,10 +17,10 @@ open Termops
open Reductionops
open Term
open Vars
-open Context
open Pattern
open Patternops
open Misctypes
+open Context.Rel.Declaration
(*i*)
(* Given a term with second-order variables in it,
@@ -49,12 +49,12 @@ type bound_ident_map = Id.t Id.Map.t
exception PatternMatchingFailure
-let warn_bound_meta name =
- msg_warning (str "Collision between bound variable " ++ pr_id name ++
- str " and a metavariable of same name.")
+let warn_meta_collision =
+ CWarnings.create ~name:"meta-collision" ~category:"ltac"
+ (fun name ->
+ strbrk "Collision between bound variable " ++ pr_id name ++
+ strbrk " and a metavariable of same name.")
-let warn_bound_bound name =
- msg_warning (str "Collision between bound variables of name " ++ pr_id name)
let constrain n (ids, m as x) (names, terms as subst) =
try
@@ -62,18 +62,19 @@ let constrain n (ids, m as x) (names, terms as subst) =
if List.equal Id.equal ids ids' && eq_constr m m' then subst
else raise PatternMatchingFailure
with Not_found ->
- let () = if Id.Map.mem n names then warn_bound_meta n in
+ let () = if Id.Map.mem n names then warn_meta_collision n in
(names, Id.Map.add n x terms)
let add_binders na1 na2 binding_vars (names, terms as subst) =
match na1, na2 with
| Name id1, Name id2 when Id.Set.mem id1 binding_vars ->
if Id.Map.mem id1 names then
- let () = warn_bound_bound id1 in
+ let () = Glob_ops.warn_variable_collision id1 in
(names, terms)
else
let names = Id.Map.add id1 id2 names in
- let () = if Id.Map.mem id1 terms then warn_bound_meta id1 in
+ let () = if Id.Map.mem id1 terms then
+ warn_meta_collision id1 in
(names, terms)
| _ -> subst
@@ -255,24 +256,24 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels
sorec ctx env subst c1 c2
| PProd (na1,c1,d1), Prod(na2,c2,d2) ->
- sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
+ sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env)
(add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
| PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
- sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env)
+ sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env)
(add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
| PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
- sorec ((na1,na2,t2)::ctx) (Environ.push_rel (na2,Some c2,t2) env)
+ sorec ((na1,na2,t2)::ctx) (Environ.push_rel (LocalDef (na2,c2,t2)) env)
(add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2
| PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
let ctx_b2,b2 = decompose_lam_n_decls ci.ci_cstr_ndecls.(0) b2 in
let ctx_b2',b2' = decompose_lam_n_decls ci.ci_cstr_ndecls.(1) b2' in
- let n = rel_context_length ctx_b2 in
- let n' = rel_context_length ctx_b2' in
+ let n = Context.Rel.length ctx_b2 in
+ let n' = Context.Rel.length ctx_b2' in
if noccur_between 1 n b2 && noccur_between 1 n' b2' then
- let f l (na,_,t) = (Anonymous,na,t)::l in
+ let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,t)::l in
let ctx_br = List.fold_left f ctx ctx_b2 in
let ctx_br' = List.fold_left f ctx ctx_b2' in
let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in
@@ -368,21 +369,21 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
| [c1; c2] -> mk_ctx (mkLambda (x, c1, c2))
| _ -> assert false
in
- let env' = Environ.push_rel (x,None,c1) env in
+ let env' = Environ.push_rel (LocalAssum (x,c1)) env in
try_aux [(env, c1); (env', c2)] next_mk_ctx next
| Prod (x,c1,c2) ->
let next_mk_ctx = function
| [c1; c2] -> mk_ctx (mkProd (x, c1, c2))
| _ -> assert false
in
- let env' = Environ.push_rel (x,None,c1) env in
+ let env' = Environ.push_rel (LocalAssum (x,c1)) env in
try_aux [(env, c1); (env', c2)] next_mk_ctx next
| LetIn (x,c1,t,c2) ->
let next_mk_ctx = function
| [c1; c2] -> mk_ctx (mkLetIn (x, c1, t, c2))
| _ -> assert false
in
- let env' = Environ.push_rel (x,Some c1,t) env in
+ let env' = Environ.push_rel (LocalDef (x,c1,t)) env in
try_aux [(env, c1); (env', c2)] next_mk_ctx next
| App (c1,lc) ->
let topdown = true in
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index c3877c56..85125a50 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -7,12 +7,11 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Term
open Vars
-open Context
open Inductiveops
open Environ
open Glob_term
@@ -25,6 +24,7 @@ open Nametab
open Mod_subst
open Misctypes
open Decl_kinds
+open Context.Named.Declaration
let dl = Loc.ghost
@@ -34,8 +34,15 @@ let print_universes = Flags.univ_print
(** If true, prints local context of evars, whatever print_arguments *)
let print_evar_arguments = ref false
-let add_name na b t (nenv, env) = add_name na nenv, push_rel (na, b, t) env
-let add_name_opt na b t (nenv, env) =
+let add_name na b t (nenv, env) =
+ let open Context.Rel.Declaration in
+ add_name na nenv, push_rel (match b with
+ | None -> LocalAssum (na,t)
+ | Some b -> LocalDef (na,b,t)
+ )
+ env
+
+let add_name_opt na b t (nenv, env) =
match t with
| None -> Termops.add_name na nenv, env
| Some t -> add_name na b t (nenv, env)
@@ -199,7 +206,7 @@ let computable p k =
engendrera un prédicat non dépendant) *)
let sign,ccl = decompose_lam_assum p in
- Int.equal (rel_context_length sign) (k + 1)
+ Int.equal (Context.Rel.length sign) (k + 1)
&&
noccur_between 1 (k+1) ccl
@@ -315,8 +322,8 @@ let is_nondep_branch c l =
try
(* FIXME: do better using tags from l *)
let sign,ccl = decompose_lam_n_decls (List.length l) c in
- noccur_between 1 (rel_context_length sign) ccl
- with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *)
+ noccur_between 1 (Context.Rel.length sign) ccl
+ with e when CErrors.noncritical e -> (* Not eta-expanded or not reduced *)
false
let extract_nondep_branches test c b l =
@@ -511,14 +518,20 @@ let rec detype flags avoid env sigma t =
else noparams ()
| Evar (evk,cl) ->
- let bound_to_itself_or_letin (id,b,_) c =
- b != None ||
- try let n = List.index Name.equal (Name id) (fst env) in
- isRelN n c
- with Not_found -> isVarId id c in
+ let bound_to_itself_or_letin decl c =
+ match decl with
+ | LocalDef _ -> true
+ | LocalAssum (id,_) ->
+ try let n = List.index Name.equal (Name id) (fst env) in
+ isRelN n c
+ with Not_found -> isVarId id c
+ in
let id,l =
try
- let id = Evd.evar_ident evk sigma in
+ let id = match Evd.evar_ident evk sigma with
+ | None -> Evd.pr_evar_suggested_name evk sigma
+ | Some id -> id
+ in
let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in
let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> match kind_of_term c with Rel n -> (fvs,Int.Set.add n rels) | Var id -> (Id.Set.add id fvs,rels) | _ -> (fvs,rels)) (Id.Set.empty,Int.Set.empty) l in
let l = Evd.evar_instance_array (fun d c -> not !print_evar_arguments && (bound_to_itself_or_letin d c && not (isRel c && Int.Set.mem (destRel c) rels || isVar c && (Id.Set.mem (destVar c) fvs)))) (Evd.find sigma evk) cl in
@@ -607,7 +620,7 @@ and share_names flags n l avoid env sigma c t =
share_names flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c'
(* If built with the f/n notation: we renounce to share names *)
| _ ->
- if n>0 then msg_warning (strbrk "Detyping.detype: cannot factorize fix enough");
+ if n>0 then Feedback.msg_debug (strbrk "Detyping.detype: cannot factorize fix enough");
let c = detype flags avoid env sigma c in
let t = detype flags avoid env sigma t in
(List.rev l,c,t)
@@ -618,7 +631,7 @@ and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl =
let mat = build_tree Anonymous (snd flags) (avoid,env) ci bl in
List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype flags avoid env sigma c))
mat
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
Array.to_list
(Array.map3 (detype_eqn flags avoid env sigma) constructs consnargsl bl)
@@ -673,23 +686,36 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c =
match bk with
| BProd -> GProd (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r)
| BLambda -> GLambda (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r)
- | BLetIn -> GLetIn (dl, na',detype (lax,false) avoid env sigma (Option.get body), r)
+ | BLetIn ->
+ let c = detype (lax,false) avoid env sigma (Option.get body) in
+ (* Heuristic: we display the type if in Prop *)
+ let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in
+ let c = if s != InProp then c else
+ GCast (dl, c, CastConv (detype (lax,false) avoid env sigma ty)) in
+ GLetIn (dl, na', c, r)
let detype_rel_context ?(lax=false) where avoid env sigma sign =
let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in
let rec aux avoid env = function
| [] -> []
- | (na,b,t)::rest ->
+ | decl::rest ->
+ let open Context.Rel.Declaration in
+ let na = get_name decl in
+ let t = get_type decl in
let na',avoid' =
match where with
| None -> na,avoid
| Some c ->
- if b != None then
+ if is_local_def decl then
compute_displayed_let_name_in
(RenamingElsewhereFor (fst env,c)) avoid na c
else
compute_displayed_name_in
(RenamingElsewhereFor (fst env,c)) avoid na c in
+ let b = match decl with
+ | LocalAssum _ -> None
+ | LocalDef (_,b,_) -> Some b
+ in
let b' = Option.map (detype (lax,false) avoid env sigma) b in
let t' = detype (lax,false) avoid env sigma t in
(na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index 838588dc..c51cb0f4 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -8,7 +8,6 @@
open Names
open Term
-open Context
open Environ
open Glob_term
open Termops
@@ -46,7 +45,7 @@ val detype_case :
val detype_sort : evar_map -> sorts -> glob_sort
val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) ->
- evar_map -> rel_context -> glob_decl list
+ evar_map -> Context.Rel.t -> glob_decl list
val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 637a9e50..9fd55a48 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -6,22 +6,25 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Term
open Vars
-open Closure
+open CClosure
open Reduction
open Reductionops
open Termops
open Environ
open Recordops
open Evarutil
+open Evardefine
open Evarsolve
open Globnames
open Evd
open Pretype_errors
+open Sigma.Notations
+open Context.Rel.Declaration
type unify_fun = transparent_state ->
env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result
@@ -39,12 +42,7 @@ let _ = Goptions.declare_bool_option {
let unfold_projection env evd ts p c =
let cst = Projection.constant p in
if is_transparent_constant ts cst then
- let c' = Some (mkProj (Projection.make cst true, c)) in
- match ReductionBehaviour.get (Globnames.ConstRef cst) with
- | None -> c'
- | Some (recargs, nargs, flags) ->
- if (List.mem `ReductionNeverUnfold flags) then None
- else c'
+ Some (mkProj (Projection.make cst true, c))
else None
let eval_flexible_term ts env evd c =
@@ -54,12 +52,15 @@ let eval_flexible_term ts env evd c =
then constant_opt_value_in env cu
else None
| Rel n ->
- (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v
- with Not_found -> None)
+ (try match lookup_rel n env with
+ | LocalAssum _ -> None
+ | LocalDef (_,v,_) -> Some (lift n v)
+ with Not_found -> None)
| Var id ->
(try
if is_transparent_variable ts id then
- let (_,v,_) = lookup_named id env in v
+ let open Context.Named.Declaration in
+ lookup_named id env |> get_value
else None
with Not_found -> None)
| LetIn (_,b,_,c) -> Some (subst1 b c)
@@ -96,21 +97,20 @@ let position_problem l2r = function
| CONV -> None
| CUMUL -> Some l2r
-let occur_rigidly ev evd t =
- let (l, app) = decompose_app_vect t in
- let rec aux t =
+let occur_rigidly (evk,_ as ev) evd t =
+ let rec aux t =
match kind_of_term (whd_evar evd t) with
| App (f, c) -> if aux f then Array.exists aux c else false
| Construct _ | Ind _ | Sort _ | Meta _ | Fix _ | CoFix _ -> true
| Proj (p, c) -> not (aux c)
- | Evar (ev',_) -> if Evar.equal ev ev' then raise Occur else false
+ | Evar (evk',_) -> if Evar.equal evk evk' then raise Occur else false
| Cast (p, _, _) -> aux p
| Lambda _ | LetIn _ -> false
| Const _ -> false
| Prod (_, b, t) -> ignore(aux b || aux t); true
| Rel _ | Var _ -> false
- | Case _ -> false
- in Array.exists (fun t -> try ignore(aux t); false with Occur -> true) app
+ | Case (_,_,c,_) -> if eq_constr (mkEvar ev) c then raise Occur else false
+ in try ignore(aux t); false with Occur -> true
(* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose
the problem (t1 stack1) = (t2 stack2) into a problem
@@ -138,6 +138,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) =
try
match kind_of_term t2 with
Prod (_,a,b) -> (* assert (l2=[]); *)
+ let _, a, b = destProd (Evarutil.nf_evar sigma t2) in
if dependent (mkRel 1) b then raise Not_found
else lookup_canonical_conversion (proji, Prod_cs),
(Stack.append_app [|a;pop b|] Stack.empty)
@@ -308,7 +309,7 @@ let exact_ise_stack2 env evd f sk1 sk2 =
if Reductionops.Stack.compare_shape sk1 sk2 then
ise_stack2 evd (List.rev sk1) (List.rev sk2)
else UnifFailure (evd, (* Dummy *) NotSameHead)
-
+
let rec evar_conv_x ts env evd pbty term1 term2 =
let term1 = whd_head_evar evd term1 in
let term2 = whd_head_evar evd term2 in
@@ -317,25 +318,22 @@ let rec evar_conv_x ts env evd pbty term1 term2 =
Note: incomplete heuristic... *)
let ground_test =
if is_ground_term evd term1 && is_ground_term evd term2 then (
- let evd, e =
+ let e =
try
let evd, b = infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts)
env evd term1 term2
in
- if b then evd, None
- else evd, Some (ConversionFailed (env,term1,term2))
- with Univ.UniverseInconsistency e -> evd, Some (UnifUnivInconsistency e)
+ if b then Success evd
+ else UnifFailure (evd, ConversionFailed (env,term1,term2))
+ with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e)
in
match e with
- | None -> Some (evd, e)
- | Some e ->
- if is_ground_env evd env then Some (evd, Some e)
- else None)
+ | UnifFailure (evd, e) when not (is_ground_env evd env) -> None
+ | _ -> Some e)
else None
in
match ground_test with
- | Some (evd, None) -> Success evd
- | Some (evd, Some e) -> UnifFailure (evd,e)
+ | Some result -> result
| None ->
(* Until pattern-unification is used consistently, use nohdbeta to not
destroy beta-redexes that can be used for 1st-order unification *)
@@ -364,8 +362,6 @@ let rec evar_conv_x ts env evd pbty term1 term2 =
and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) =
- let default_fail i = (* costly *)
- UnifFailure (i,ConversionFailed (env, Stack.zip appr1, Stack.zip appr2)) in
let quick_fail i = (* not costly, loses info *)
UnifFailure (i, NotSameHead)
in
@@ -393,7 +389,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
assert (match sk with [] -> true | _ -> false);
let (na,c1,c'1) = destLambda term in
let c = nf_evar evd c1 in
- let env' = push_rel (na,None,c) env in
+ let env' = push_rel (LocalAssum (na,c)) env in
let out1 = whd_betaiota_deltazeta_for_iota_state
(fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in
let out2 = whd_nored_state evd
@@ -417,7 +413,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
let not_only_app = Stack.not_purely_applicative skM in
let f1 i =
match Stack.list_of_app_stack skF with
- | None -> default_fail evd
+ | None -> quick_fail evd
| Some lF ->
let tM = Stack.zip apprM in
miller_pfenning on_left
@@ -431,7 +427,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
else quick_fail i
and delta i =
switch (evar_eqappr_x ts env i pbty) (apprF,cstsF)
- (whd_betaiota_deltazeta_for_iota_state (fst ts) env i cstsM (vM,skM))
+ (whd_betaiota_deltazeta_for_iota_state
+ (fst ts) env i cstsM (vM,skM))
in
let default i = ise_try i [f1; consume apprF apprM; delta]
in
@@ -448,7 +445,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
try
let termM' = Retyping.expand_projection env evd p c [] in
let apprM', cstsM' =
- whd_betaiota_deltazeta_for_iota_state (fst ts) env evd cstsM (termM',skM)
+ whd_betaiota_deltazeta_for_iota_state
+ (fst ts) env evd cstsM (termM',skM)
in
let delta' i =
switch (evar_eqappr_x ts env i pbty) (apprF,cstsF) (apprM',cstsM')
@@ -464,10 +462,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
let flex_rigid on_left ev (termF, skF as apprF) (termR, skR as apprR) =
let switch f a b = if on_left then f a b else f b a in
let eta evd =
- match kind_of_term termR with
- | Lambda _ -> eta env evd false skR termR skF termF
- | Construct u -> eta_constructor ts env evd skR u skF termF
- | _ -> UnifFailure (evd,NotSameHead)
+ match kind_of_term termR with
+ | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR ->
+ eta env evd false skR termR skF termF
+ | Construct u -> eta_constructor ts env evd skR u skF termF
+ | _ -> UnifFailure (evd,NotSameHead)
in
match Stack.list_of_app_stack skF with
| None ->
@@ -479,7 +478,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
ise_try evd
[eta;(* Postpone the use of an heuristic *)
(fun i ->
- if not (occur_rigidly (fst ev) i tR) then
+ if not (occur_rigidly ev i tR) then
let i,tF =
if isRel tR || isVar tR then
(* Optimization so as to generate candidates *)
@@ -497,15 +496,18 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
(* Evar must be undefined since we have flushed evars *)
let () = if !debug_unification then
let open Pp in
- pp (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ())
+ Feedback.msg_notice (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ())
++ fnl ()) in
match (flex_kind_of_term (fst ts) env evd term1 sk1,
flex_kind_of_term (fst ts) env evd term2 sk2) with
| Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) ->
+ (* sk1[?ev1] =? sk2[?ev2] *)
let f1 i =
+ (* Try first-order unification *)
match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with
- |None, Success i' ->
- (* Evar can be defined in i' *)
+ | None, Success i' ->
+ (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *)
+ (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *)
let ev1' = whd_evar i' (mkEvar ev1) in
if isEvar ev1' then
solve_simple_eqn (evar_conv_x ts) env i'
@@ -513,7 +515,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
else
evar_eqappr_x ts env evd pbty
((ev1', sk1), csts1) ((term2, sk2), csts2)
- |Some (r,[]), Success i' ->
+ | Some (r,[]), Success i' ->
+ (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *)
+ (* we now unify r[?ev1] and ?ev2 *)
let ev2' = whd_evar i' (mkEvar ev2) in
if isEvar ev2' then
solve_simple_eqn (evar_conv_x ts) env i'
@@ -521,16 +525,46 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
else
evar_eqappr_x ts env evd pbty
((ev2', sk1), csts1) ((term2, sk2), csts2)
-
- |Some ([],r), Success i' ->
+ | Some ([],r), Success i' ->
+ (* Symmetrically *)
+ (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *)
+ (* we now unify ?ev1 and r[?ev2] *)
let ev1' = whd_evar i' (mkEvar ev1) in
if isEvar ev1' then
solve_simple_eqn (evar_conv_x ts) env i'
(position_problem true pbty,destEvar ev1',Stack.zip(term2,r))
else evar_eqappr_x ts env evd pbty
((ev1', sk1), csts1) ((term2, sk2), csts2)
- |_, (UnifFailure _ as x) -> x
- |Some _, _ -> UnifFailure (i,NotSameArgSize)
+ | None, (UnifFailure _ as x) ->
+ (* sk1 and sk2 have no common outer part *)
+ if Stack.not_purely_applicative sk2 then
+ (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+ flex_rigid true ev1 appr1 appr2
+ else
+ if Stack.not_purely_applicative sk1 then
+ (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+ flex_rigid false ev2 appr2 appr1
+ else
+ (* We could instead try Miller unification, then
+ postpone to see if other equations help, as in:
+ [Check fun a b : unit => (eqáµ£efl : _ a = _ a b)] *)
+ x
+ | Some _, Success _ ->
+ (* sk1 and sk2 have a common outer part *)
+ if Stack.not_purely_applicative sk2 then
+ (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+ flex_rigid true ev1 appr1 appr2
+ else
+ if Stack.not_purely_applicative sk1 then
+ (* Ad hoc compatibility with 8.4 which treated non-app as rigid *)
+ flex_rigid false ev2 appr2 appr1
+ else
+ (* We could instead try Miller unification, then
+ postpone to see if other equations help, as in:
+ [Check fun a b c : unit => (eqáµ£efl : _ a b = _ c a b)] *)
+ UnifFailure (i,NotSameArgSize)
+ | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.")
+
and f2 i =
if Evar.equal sp1 sp2 then
match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with
@@ -553,14 +587,17 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
| MaybeFlexible v1, MaybeFlexible v2 -> begin
match kind_of_term term1, kind_of_term term2 with
| LetIn (na1,b1,t1,c'1), LetIn (na2,b2,t2,c'2) ->
- let f1 i =
+ let f1 i = (* FO *)
ise_and i
- [(fun i -> evar_conv_x ts env i CONV b1 b2);
+ [(fun i -> ise_try i
+ [(fun i -> evar_conv_x ts env i CUMUL t1 t2);
+ (fun i -> evar_conv_x ts env i CUMUL t2 t1)]);
+ (fun i -> evar_conv_x ts env i CONV b1 b2);
(fun i ->
let b = nf_evar i b1 in
let t = nf_evar i t1 in
let na = Nameops.name_max na1 na2 in
- evar_conv_x ts (push_rel (na,Some b,t) env) i pbty c'1 c'2);
+ evar_conv_x ts (push_rel (LocalDef (na,b,t)) env) i pbty c'1 c'2);
(fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)]
and f2 i =
let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1)
@@ -675,7 +712,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
(fun i ->
let c = nf_evar i c1 in
let na = Nameops.name_max na1 na2 in
- evar_conv_x ts (push_rel (na,None,c) env) i CONV c'1 c'2)]
+ evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i CONV c'1 c'2)]
| Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2
| Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1
@@ -708,10 +745,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
ise_try evd [f3; f4]
(* Eta-expansion *)
- | Rigid, _ when isLambda term1 ->
+ | Rigid, _ when isLambda term1 && (* if ever ill-typed: *) List.is_empty sk1 ->
eta env evd true sk1 term1 sk2 term2
- | _, Rigid when isLambda term2 ->
+ | _, Rigid when isLambda term2 && (* if ever ill-typed: *) List.is_empty sk2 ->
eta env evd false sk2 term2 sk1 term1
| Rigid, Rigid -> begin
@@ -726,7 +763,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
in Success evd'
with Univ.UniverseInconsistency p ->
UnifFailure (evd,UnifUnivInconsistency p)
- | e when Errors.noncritical e -> UnifFailure (evd,NotSameHead))
+ | e when CErrors.noncritical e -> UnifFailure (evd,NotSameHead))
| Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty ->
ise_and evd
@@ -734,7 +771,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
(fun i ->
let c = nf_evar i c1 in
let na = Nameops.name_max n1 n2 in
- evar_conv_x ts (push_rel (na,None,c) env) i pbty c'1 c'2)]
+ evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i pbty c'1 c'2)]
| Rel x1, Rel x2 ->
if Int.equal x1 x2 then
@@ -830,7 +867,9 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
(i,t2::ks, m-1, test)
else
let dloc = (Loc.ghost,Evar_kinds.InternalHole) in
- let (i',ev) = new_evar env i ~src:dloc (substl ks b) in
+ let i = Sigma.Unsafe.of_evar_map i in
+ let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in
+ let i' = Sigma.to_evar_map i' in
(i', ev :: ks, m - 1,test))
(evd,[],List.length bs,fun i -> Success i) bs
in
@@ -854,7 +893,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 =
let mib = lookup_mind (fst ind) env in
match mib.Declarations.mind_record with
- | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite ->
+ | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite ->
let pars = mib.Declarations.mind_nparams in
(try
let l1' = Stack.tail pars sk1 in
@@ -909,6 +948,7 @@ let choose_less_dependent_instance evk evd term args =
| [] -> None
| (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd)
+open Context.Named.Declaration
let apply_on_subterm env evdref f c t =
let rec applyrec (env,(k,c) as acc) t =
(* By using eq_constr, we make an approximation, for instance, we *)
@@ -919,7 +959,7 @@ let apply_on_subterm env evdref f c t =
match kind_of_term t with
| Evar (evk,args) when Evd.is_undefined !evdref evk ->
let ctx = evar_filtered_context (Evd.find_undefined !evdref evk) in
- let g (_,b,_) a = if Option.is_empty b then applyrec acc a else a in
+ let g decl a = if is_local_assum decl then applyrec acc a else a in
mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args)))
| _ ->
map_constr_with_binders_left_to_right
@@ -936,17 +976,17 @@ let filter_possible_projections c ty ctxt args =
let fv2 = collect_vars (mkApp (c,args)) in
let len = Array.length args in
let tyvars = collect_vars ty in
- List.map_i (fun i (id,b,_) ->
+ List.map_i (fun i decl ->
let () = assert (i < len) in
let a = Array.unsafe_get args i in
- (match b with None -> false | Some c -> not (isRel c || isVar c)) ||
+ (match decl with LocalAssum _ -> false | LocalDef (_,c,_) -> not (isRel c || isVar c)) ||
a == c ||
(* Here we make an approximation, for instance, we could also be *)
(* interested in finding a term u convertible to c such that a occurs *)
(* in u *)
isRel a && Int.Set.mem (destRel a) fv1 ||
isVar a && Id.Set.mem (destVar a) fv2 ||
- Id.Set.mem id tyvars)
+ Id.Set.mem (get_id decl) tyvars)
0 ctxt
let solve_evars = ref (fun _ -> failwith "solve_evars not installed")
@@ -977,17 +1017,18 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
let env_evar = evar_filtered_env evi in
let sign = named_context_val env_evar in
let ctxt = evar_filtered_context evi in
- let instance = List.map mkVar (List.map pi1 ctxt) in
+ let instance = List.map mkVar (List.map get_id ctxt) in
let rec make_subst = function
- | (id,_,t)::ctxt', c::l, occs::occsl when isVarId id c ->
+ | decl'::ctxt', c::l, occs::occsl when isVarId (get_id decl') c ->
begin match occs with
| Some _ ->
error "Cannot force abstraction on identity instance."
| None ->
make_subst (ctxt',l,occsl)
end
- | (id,_,t)::ctxt', c::l, occs::occsl ->
+ | decl'::ctxt', c::l, occs::occsl ->
+ let (id,_,t) = to_tuple decl' in
let evs = ref [] in
let ty = Retyping.get_type_of env_rhs evd c in
let filter' = filter_possible_projections c ty ctxt args in
@@ -1004,7 +1045,9 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
| None ->
let evty = set_holes evdref cty subst in
let instance = Filter.filter_list filter instance in
- let evd,ev = new_evar_instance sign !evdref evty ~filter instance in
+ let evd = Sigma.Unsafe.of_evar_map !evdref in
+ let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in
+ let evd = Sigma.to_evar_map evd in
evdref := evd;
evsref := (fst (destEvar ev),evty)::!evsref;
ev in
@@ -1038,7 +1081,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
match evar_conv_x ts env_evar evd CUMUL idty evty with
| UnifFailure _ -> error "Cannot find an instance"
| Success evd ->
- match reconsider_conv_pbs (evar_conv_x ts) evd with
+ match reconsider_unif_constraints (evar_conv_x ts) evd with
| UnifFailure _ -> error "Cannot find an instance"
| Success evd ->
evd
@@ -1061,7 +1104,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
abstract_free_holes evd subst, true
with TypingFailed evd -> evd, false
-let second_order_matching_with_args ts env evd ev l t =
+let second_order_matching_with_args ts env evd pbty ev l t =
(*
let evd,ev = evar_absorb_arguments env evd ev l in
let argoccs = Array.map_to_list (fun _ -> None) (snd ev) in
@@ -1069,8 +1112,9 @@ let second_order_matching_with_args ts env evd ev l t =
if b then Success evd
else UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t))
if b then Success evd else
-*)
- UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t))
+ *)
+ let pb = (pbty,env,mkApp(mkEvar ev,l),t) in
+ UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities))
let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in
@@ -1086,7 +1130,9 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
type inference *)
(match choose_less_dependent_instance evk1 evd term2 args1 with
| Some evd -> Success evd
- | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)))
+ | None ->
+ let reason = ProblemBeyondCapabilities in
+ UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason)))
| (Rel _|Var _), Evar (evk2,args2) when app_empty
&& List.for_all (fun a -> Term.eq_constr a term1 || isEvar a)
(remove_instance_local_defs evd evk2 args2) ->
@@ -1094,12 +1140,14 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
type inference *)
(match choose_less_dependent_instance evk2 evd term1 args2 with
| Some evd -> Success evd
- | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)))
+ | None ->
+ let reason = ProblemBeyondCapabilities in
+ UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason)))
| Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 ->
- let f env evd pbty x y = is_trans_fconv pbty ts env evd x y in
+ let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in
Success (solve_refl ~can_drop:true f env evd
(position_problem true pbty) evk1 args1 args2)
- | Evar ev1, Evar ev2 ->
+ | Evar ev1, Evar ev2 when app_empty ->
Success (solve_evar_evar ~force:true
(evar_define (evar_conv_x ts) ~choose:true) (evar_conv_x ts) env evd
(position_problem true pbty) ev1 ev2)
@@ -1109,27 +1157,32 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
ise_try evd
[(fun evd -> first_order_unification ts env evd (ev1,l1) appr2);
(fun evd ->
- second_order_matching_with_args ts env evd ev1 l1 t2)]
+ second_order_matching_with_args ts env evd pbty ev1 l1 t2)]
| _,Evar ev2 when Array.length l2 <= Array.length l1 ->
(* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *)
(* and otherwise second-order matching *)
ise_try evd
[(fun evd -> first_order_unification ts env evd (ev2,l2) appr1);
(fun evd ->
- second_order_matching_with_args ts env evd ev2 l2 t1)]
+ second_order_matching_with_args ts env evd pbty ev2 l2 t1)]
| Evar ev1,_ ->
(* Try second-order pattern-matching *)
- second_order_matching_with_args ts env evd ev1 l1 t2
+ second_order_matching_with_args ts env evd pbty ev1 l1 t2
| _,Evar ev2 ->
(* Try second-order pattern-matching *)
- second_order_matching_with_args ts env evd ev2 l2 t1
+ second_order_matching_with_args ts env evd pbty ev2 l2 t1
| _ ->
(* Some head evar have been instantiated, or unknown kind of problem *)
evar_conv_x ts env evd pbty t1 t2
+let error_cannot_unify env evd pb ?reason t1 t2 =
+ Pretype_errors.error_cannot_unify_loc
+ (loc_of_conv_pb evd pb) env
+ evd ?reason (t1, t2)
+
let check_problems_are_solved env evd =
match snd (extract_all_conv_pbs evd) with
- | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2)
+ | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb t1 t2
| _ -> ()
let max_undefined_with_candidates evd =
@@ -1160,7 +1213,7 @@ let rec solve_unconstrained_evars_with_candidates ts evd =
let conv_algo = evar_conv_x ts in
let evd = check_evar_instance evd evk a conv_algo in
let evd = Evd.define evk a evd in
- match reconsider_conv_pbs conv_algo evd with
+ match reconsider_unif_constraints conv_algo evd with
| Success evd -> solve_unconstrained_evars_with_candidates ts evd
| UnifFailure _ -> aux l
with
@@ -1174,16 +1227,16 @@ let rec solve_unconstrained_evars_with_candidates ts evd =
let solve_unconstrained_impossible_cases env evd =
Evd.fold_undefined (fun evk ev_info evd' ->
match ev_info.evar_source with
- | _,Evar_kinds.ImpossibleCase ->
+ | loc,Evar_kinds.ImpossibleCase ->
let j, ctx = coq_unit_judge () in
- let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd' ctx in
+ let evd' = Evd.merge_context_set Evd.univ_flexible_alg ~loc evd' ctx in
let ty = j_type j in
let conv_algo = evar_conv_x full_transparent_state in
let evd' = check_evar_instance evd' evk ty conv_algo in
Evd.define evk ty evd'
| _ -> evd') evd evd
-let consider_remaining_unif_problems env
+let solve_unif_constraints_with_heuristics env
?(ts=Conv_oracle.get_transp_state (Environ.oracle env)) evd =
let evd = solve_unconstrained_evars_with_candidates ts evd in
let rec aux evd pbs progress stuck =
@@ -1198,23 +1251,23 @@ let consider_remaining_unif_problems env
aux evd pbs progress (pb :: stuck)
end
| UnifFailure (evd,reason) ->
- Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb)
- env evd ~reason (t1, t2))
+ error_cannot_unify env evd pb ~reason t1 t2)
| _ ->
if progress then aux evd stuck false []
else
match stuck with
| [] -> (* We're finished *) evd
| (pbty,env,t1,t2 as pb) :: _ ->
- (* There remains stuck problems *)
- Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb)
- env evd (t1, t2)
+ (* There remains stuck problems *)
+ error_cannot_unify env evd pb t1 t2
in
let (evd,pbs) = extract_all_conv_pbs evd in
let heuristic_solved_evd = aux evd pbs false [] in
check_problems_are_solved env heuristic_solved_evd;
solve_unconstrained_impossible_cases env heuristic_solved_evd
+let consider_remaining_unif_problems = solve_unif_constraints_with_heuristics
+
(* Main entry points *)
exception UnableToUnify of evar_map * unification_error
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index 14947c89..2231e5bc 100644
--- a/pretyping/evarconv.mli
+++ b/pretyping/evarconv.mli
@@ -33,7 +33,10 @@ val e_cumul : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr -
(** Try heuristics to solve pending unification problems and to solve
evars with candidates *)
+val solve_unif_constraints_with_heuristics : env -> ?ts:transparent_state -> evar_map -> evar_map
+
val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map -> evar_map
+(** @deprecated Alias for [solve_unif_constraints_with_heuristics] *)
(** Check all pending unification problems are solved and raise an
error otherwise *)
diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml
new file mode 100644
index 00000000..f9ab75ce
--- /dev/null
+++ b/pretyping/evardefine.ml
@@ -0,0 +1,207 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Util
+open Pp
+open Names
+open Term
+open Vars
+open Termops
+open Namegen
+open Environ
+open Evd
+open Evarutil
+open Pretype_errors
+open Sigma.Notations
+
+let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in
+ (Sigma.to_evar_map evd, evk)
+
+let env_nf_evar sigma env =
+ let open Context.Rel.Declaration in
+ process_rel_context
+ (fun d e -> push_rel (map_constr (nf_evar sigma) d) e) env
+
+let env_nf_betaiotaevar sigma env =
+ let open Context.Rel.Declaration in
+ process_rel_context
+ (fun d e ->
+ push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env
+
+(****************************************)
+(* Operations on value/type constraints *)
+(****************************************)
+
+type type_constraint = types option
+
+type val_constraint = constr option
+
+(* Old comment...
+ * Basically, we have the following kind of constraints (in increasing
+ * strength order):
+ * (false,(None,None)) -> no constraint at all
+ * (true,(None,None)) -> we must build a judgement which _TYPE is a kind
+ * (_,(None,Some ty)) -> we must build a judgement which _TYPE is ty
+ * (_,(Some v,_)) -> we must build a judgement which _VAL is v
+ * Maybe a concrete datatype would be easier to understand.
+ * We differentiate (true,(None,None)) from (_,(None,Some Type))
+ * because otherwise Case(s) would be misled, as in
+ * (n:nat) Case n of bool [_]nat end would infer the predicate Type instead
+ * of Set.
+ *)
+
+(* The empty type constraint *)
+let empty_tycon = None
+
+(* Builds a type constraint *)
+let mk_tycon ty = Some ty
+
+(* Constrains the value of a type *)
+let empty_valcon = None
+
+(* Builds a value constraint *)
+let mk_valcon c = Some c
+
+let idx = Namegen.default_dependent_ident
+
+(* Refining an evar to a product *)
+
+let define_pure_evar_as_product evd evk =
+ let open Context.Named.Declaration in
+ let evi = Evd.find_undefined evd evk in
+ let evenv = evar_env evi in
+ let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
+ let concl = Reductionops.whd_all evenv evd evi.evar_concl in
+ let s = destSort concl in
+ let evd1,(dom,u1) =
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
+ (Sigma.to_evar_map evd1, e)
+ in
+ let evd2,rng =
+ let newenv = push_named (LocalAssum (id, dom)) evenv in
+ let src = evar_source evk evd1 in
+ let filter = Filter.extend 1 (evar_filter evi) in
+ if is_prop_sort s then
+ (* Impredicative product, conclusion must fall in [Prop]. *)
+ new_evar_unsafe newenv evd1 concl ~src ~filter
+ else
+ let status = univ_flexible_alg in
+ let evd3, (rng, srng) =
+ let evd1 = Sigma.Unsafe.of_evar_map evd1 in
+ let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in
+ (Sigma.to_evar_map evd3, e)
+ in
+ let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in
+ let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in
+ evd3, rng
+ in
+ let prod = mkProd (Name id, dom, subst_var id rng) in
+ let evd3 = Evd.define evk prod evd2 in
+ evd3,prod
+
+(* Refine an applied evar to a product and returns its instantiation *)
+
+let define_evar_as_product evd (evk,args) =
+ let evd,prod = define_pure_evar_as_product evd evk in
+ (* Quick way to compute the instantiation of evk with args *)
+ let na,dom,rng = destProd prod in
+ let evdom = mkEvar (fst (destEvar dom), args) in
+ let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
+ let evrng = mkEvar (fst (destEvar rng), evrngargs) in
+ evd,mkProd (na, evdom, evrng)
+
+(* Refine an evar with an abstraction
+
+ I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where:
+ - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y)
+ or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B
+ with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type
+ - x1..xq,y:A |- ?e':B
+*)
+
+let define_pure_evar_as_lambda env evd evk =
+ let open Context.Named.Declaration in
+ let evi = Evd.find_undefined evd evk in
+ let evenv = evar_env evi in
+ let typ = Reductionops.whd_all evenv evd (evar_concl evi) in
+ let evd1,(na,dom,rng) = match kind_of_term typ with
+ | Prod (na,dom,rng) -> (evd,(na,dom,rng))
+ | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ
+ | _ -> error_not_product_loc Loc.ghost env evd typ in
+ let avoid = ids_of_named_context (evar_context evi) in
+ let id =
+ next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in
+ let newenv = push_named (LocalAssum (id, dom)) evenv in
+ let filter = Filter.extend 1 (evar_filter evi) in
+ let src = evar_source evk evd1 in
+ let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
+ let lam = mkLambda (Name id, dom, subst_var id body) in
+ Evd.define evk lam evd2, lam
+
+let define_evar_as_lambda env evd (evk,args) =
+ let evd,lam = define_pure_evar_as_lambda env evd evk in
+ (* Quick way to compute the instantiation of evk with args *)
+ let na,dom,body = destLambda lam in
+ let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
+ let evbody = mkEvar (fst (destEvar body), evbodyargs) in
+ evd,mkLambda (na, dom, evbody)
+
+let rec evar_absorb_arguments env evd (evk,args as ev) = function
+ | [] -> evd,ev
+ | a::l ->
+ (* TODO: optimize and avoid introducing intermediate evars *)
+ let evd,lam = define_pure_evar_as_lambda env evd evk in
+ let _,_,body = destLambda lam in
+ let evk = fst (destEvar body) in
+ evar_absorb_arguments env evd (evk, Array.cons a args) l
+
+(* Refining an evar to a sort *)
+
+let define_evar_as_sort env evd (ev,args) =
+ let evd, u = new_univ_variable univ_rigid evd in
+ let evi = Evd.find_undefined evd ev in
+ let s = Type u in
+ let concl = Reductionops.whd_all (evar_env evi) evd evi.evar_concl in
+ let sort = destSort concl in
+ let evd' = Evd.define ev (mkSort s) evd in
+ Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s
+
+(* Propagation of constraints through application and abstraction:
+ Given a type constraint on a functional term, returns the type
+ constraint on its domain and codomain. If the input constraint is
+ an evar instantiate it with the product of 2 new evars. *)
+
+let split_tycon loc env evd tycon =
+ let rec real_split evd c =
+ let t = Reductionops.whd_all env evd c in
+ match kind_of_term t with
+ | Prod (na,dom,rng) -> evd, (na, dom, rng)
+ | Evar ev (* ev is undefined because of whd_all *) ->
+ let (evd',prod) = define_evar_as_product evd ev in
+ let (_,dom,rng) = destProd prod in
+ evd',(Anonymous, dom, rng)
+ | App (c,args) when isEvar c ->
+ let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in
+ real_split evd' (mkApp (lam,args))
+ | _ -> error_not_product_loc loc env evd c
+ in
+ match tycon with
+ | None -> evd,(Anonymous,None,None)
+ | Some c ->
+ let evd', (n, dom, rng) = real_split evd c in
+ evd', (n, mk_tycon dom, mk_tycon rng)
+
+let valcon_of_tycon x = x
+let lift_tycon n = Option.map (lift n)
+
+let pr_tycon env = function
+ None -> str "None"
+ | Some t -> Termops.print_constr_env env t
diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli
new file mode 100644
index 00000000..07b0e69d
--- /dev/null
+++ b/pretyping/evardefine.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Names
+open Term
+open Evd
+open Environ
+
+val env_nf_evar : evar_map -> env -> env
+val env_nf_betaiotaevar : evar_map -> env -> env
+
+type type_constraint = types option
+type val_constraint = constr option
+
+val empty_tycon : type_constraint
+val mk_tycon : constr -> type_constraint
+val empty_valcon : val_constraint
+val mk_valcon : constr -> val_constraint
+
+(** Instantiate an evar by as many lambda's as needed so that its arguments
+ are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into
+ [?y[vars1:=args1,vars:=args]] with
+ [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *)
+val evar_absorb_arguments : env -> evar_map -> existential -> constr list ->
+ evar_map * existential
+
+val split_tycon :
+ Loc.t -> env -> evar_map -> type_constraint ->
+ evar_map * (Name.t * type_constraint * type_constraint)
+
+val valcon_of_tycon : type_constraint -> val_constraint
+val lift_tycon : int -> type_constraint -> type_constraint
+
+val define_evar_as_product : evar_map -> existential -> evar_map * types
+val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types
+val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts
+
+(** {6 debug pretty-printer:} *)
+
+val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
+
diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index 3bf6f376..4fd03084 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -7,11 +7,10 @@
(************************************************************************)
open Util
-open Errors
+open CErrors
open Names
open Term
open Vars
-open Context
open Environ
open Termops
open Evd
@@ -20,6 +19,7 @@ open Retyping
open Reductionops
open Evarutil
open Pretype_errors
+open Sigma.Notations
let normalize_evar evd ev =
match kind_of_term (whd_evar evd (mkEvar ev)) with
@@ -42,28 +42,39 @@ let get_polymorphic_positions f =
templ.template_param_levels)
| _ -> assert false
-let refresh_level evd s =
- match Evd.is_sort_variable evd s with
- | None -> true
- | Some l -> not (Evd.is_flexible_level evd l)
-
-let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
+let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false)
+ pbty env evd t =
let evdref = ref evd in
let modified = ref false in
- let rec refresh status dir t =
- match kind_of_term t with
- | Sort (Type u as s) when
- (match Univ.universe_level u with
- | None -> true
- | Some l -> not onlyalg && refresh_level evd s) ->
+ (* direction: true for fresh universes lower than the existing ones *)
+ let refresh_sort status ~direction s =
let s' = evd_comb0 (new_sort_variable status) evdref in
let evd =
- if dir then set_leq_sort env !evdref s' s
+ if direction then set_leq_sort env !evdref s' s
else set_leq_sort env !evdref s s'
in
- modified := true; evdref := evd; mkSort s'
+ modified := true; evdref := evd; mkSort s'
+ in
+ let rec refresh ~onlyalg status ~direction t =
+ match kind_of_term t with
+ | Sort (Type u as s) ->
+ (match Univ.universe_level u with
+ | None -> refresh_sort status ~direction s
+ | Some l ->
+ (match Evd.universe_rigidity evd l with
+ | UnivRigid ->
+ if not onlyalg then refresh_sort status ~direction s
+ else t
+ | UnivFlexible alg ->
+ if onlyalg && alg then
+ (evdref := Evd.make_flexible_variable !evdref false l; t)
+ else t))
+ | Sort (Prop Pos as s) when refreshset && not direction ->
+ (* Cannot make a universe "lower" than "Set",
+ only refreshing when we want higher universes. *)
+ refresh_sort status ~direction s
| Prod (na,u,v) ->
- mkProd (na,u,refresh status dir v)
+ mkProd (na, u, refresh ~onlyalg status ~direction v)
| _ -> t
(** Refresh the types of evars under template polymorphic references *)
and refresh_term_evars onevars top t =
@@ -76,11 +87,11 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
Array.iter (refresh_term_evars onevars false) args
| Evar (ev, a) when onevars ->
let evi = Evd.find !evdref ev in
- let ty' = refresh univ_flexible true evi.evar_concl in
+ let ty' = refresh ~onlyalg univ_flexible ~direction:true evi.evar_concl in
if !modified then
evdref := Evd.add !evdref ev {evi with evar_concl = ty'}
else ()
- | _ -> iter_constr (refresh_term_evars onevars false) t
+ | _ -> Constr.iter (refresh_term_evars onevars false) t
and refresh_polymorphic_positions args pos =
let rec aux i = function
| Some l :: ls ->
@@ -96,9 +107,11 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t =
in
let t' =
if isArity t then
- (match pbty with
- | None -> t
- | Some dir -> refresh status dir t)
+ match pbty with
+ | None ->
+ (* No cumulativity needed, but we still need to refresh the algebraics *)
+ refresh ~onlyalg:true univ_flexible ~direction:false t
+ | Some direction -> refresh ~onlyalg status ~direction t
else (refresh_term_evars false true t; t)
in
if !modified then !evdref, t' else !evdref, t
@@ -140,7 +153,7 @@ let recheck_applications conv_algo env evdref t =
let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in
let rec aux i ty =
if i < Array.length argsty then
- match kind_of_term (whd_betadeltaiota env !evdref ty) with
+ match kind_of_term (whd_all env !evdref ty) with
| Prod (na, dom, codom) ->
(match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with
| Success evd -> evdref := evd;
@@ -163,7 +176,8 @@ type 'a update =
| UpdateWith of 'a
| NoUpdate
-let inst_of_vars sign = Array.map_of_list (fun (id,_,_) -> mkVar id) sign
+open Context.Named.Declaration
+let inst_of_vars sign = Array.map_of_list (mkVar % get_id) sign
let restrict_evar_key evd evk filter candidates =
match filter, candidates with
@@ -181,7 +195,9 @@ let restrict_evar_key evd evk filter candidates =
let candidates = match candidates with
| NoUpdate -> evi.evar_candidates
| UpdateWith c -> Some c in
- restrict_evar evd evk filter candidates
+ let sigma = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in
+ (Sigma.to_evar_map sigma, evk)
end
(* Restrict an applied evar and returns its restriction in the same context *)
@@ -206,32 +222,32 @@ let restrict_instance evd evk filter argsv =
let evi = Evd.find evd evk in
Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv
+open Context.Rel.Declaration
let noccur_evar env evd evk c =
let cache = ref Int.Set.empty (* cache for let-ins *) in
- let rec occur_rec (k, env as acc) c =
+ let rec occur_rec check_types (k, env as acc) c =
match kind_of_term c with
| Evar (evk',args' as ev') ->
(match safe_evar_value evd ev' with
- | Some c -> occur_rec acc c
+ | Some c -> occur_rec check_types acc c
| None ->
if Evar.equal evk evk' then raise Occur
- else Array.iter (occur_rec acc) args')
+ else (if check_types then
+ occur_rec false acc (existential_type evd ev');
+ Array.iter (occur_rec check_types acc) args'))
| Rel i when i > k ->
- if not (Int.Set.mem (i-k) !cache) then
- (match pi2 (Environ.lookup_rel i env) with
- | None -> ()
- | Some b -> cache := Int.Set.add (i-k) !cache; occur_rec acc (lift i b))
- | Proj (p,c) ->
- let c =
- try Retyping.expand_projection env evd p c []
- with Retyping.RetypeError _ ->
- (* Can happen when called from w_unify which doesn't assign evars/metas
- eagerly enough *) c
- in occur_rec acc c
+ if not (Int.Set.mem (i-k) !cache) then
+ let decl = Environ.lookup_rel i env in
+ if check_types then
+ (cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (get_type decl)));
+ (match decl with
+ | LocalAssum _ -> ()
+ | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i b))
+ | Proj (p,c) -> occur_rec true acc c
| _ -> iter_constr_with_full_binders (fun rd (k,env) -> (succ k, push_rel rd env))
- occur_rec acc c
+ (occur_rec check_types) acc c
in
- try occur_rec (0,env) c; true with Occur -> false
+ try occur_rec false (0,env) c; true with Occur -> false
(***************************************)
(* Managing chains of local definitons *)
@@ -242,9 +258,11 @@ let noccur_evar env evd evk c =
variable in its family of aliased variables *)
let compute_var_aliases sign =
- List.fold_right (fun (id,b,c) aliases ->
- match b with
- | Some t ->
+ let open Context.Named.Declaration in
+ List.fold_right (fun decl aliases ->
+ let id = get_id decl in
+ match decl with
+ | LocalDef (_,t,_) ->
(match kind_of_term t with
| Var id' ->
let aliases_of_id =
@@ -252,27 +270,30 @@ let compute_var_aliases sign =
Id.Map.add id (aliases_of_id@[t]) aliases
| _ ->
Id.Map.add id [t] aliases)
- | None -> aliases)
+ | LocalAssum _ -> aliases)
sign Id.Map.empty
let compute_rel_aliases var_aliases rels =
- snd (List.fold_right (fun (_,b,u) (n,aliases) ->
- (n-1,
- match b with
- | Some t ->
- (match kind_of_term t with
- | Var id' ->
- let aliases_of_n =
- try Id.Map.find id' var_aliases with Not_found -> [] in
- Int.Map.add n (aliases_of_n@[t]) aliases
- | Rel p ->
- let aliases_of_n =
- try Int.Map.find (p+n) aliases with Not_found -> [] in
- Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases
- | _ ->
- Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases)
- | None -> aliases))
- rels (List.length rels,Int.Map.empty))
+ snd (List.fold_right
+ (fun decl (n,aliases) ->
+ (n-1,
+ match decl with
+ | LocalDef (_,t,u) ->
+ (match kind_of_term t with
+ | Var id' ->
+ let aliases_of_n =
+ try Id.Map.find id' var_aliases with Not_found -> [] in
+ Int.Map.add n (aliases_of_n@[t]) aliases
+ | Rel p ->
+ let aliases_of_n =
+ try Int.Map.find (p+n) aliases with Not_found -> [] in
+ Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases
+ | _ ->
+ Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases)
+ | LocalAssum _ -> aliases)
+ )
+ rels
+ (List.length rels,Int.Map.empty))
let make_alias_map env =
(* We compute the chain of aliases for each var and rel *)
@@ -306,13 +327,13 @@ let normalize_alias aliases x =
let normalize_alias_var var_aliases id =
destVar (normalize_alias (var_aliases,Int.Map.empty) (mkVar id))
-let extend_alias (_,b,_) (var_aliases,rel_aliases) =
+let extend_alias decl (var_aliases,rel_aliases) =
let rel_aliases =
Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (lift 1) l))
rel_aliases Int.Map.empty in
let rel_aliases =
- match b with
- | Some t ->
+ match decl with
+ | LocalDef(_,t,_) ->
(match kind_of_term t with
| Var id' ->
let aliases_of_binder =
@@ -324,7 +345,7 @@ let extend_alias (_,b,_) (var_aliases,rel_aliases) =
Int.Map.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases
| _ ->
Int.Map.add 1 [lift 1 t] rel_aliases)
- | None -> rel_aliases in
+ | LocalAssum _ -> rel_aliases in
(var_aliases, rel_aliases)
let expand_alias_once aliases x =
@@ -430,16 +451,17 @@ let get_actual_deps aliases l t =
| Rel n -> Int.Set.mem n fv_rels
| _ -> assert false) l
+open Context.Named.Declaration
let remove_instance_local_defs evd evk args =
let evi = Evd.find evd evk in
let len = Array.length args in
let rec aux sign i = match sign with
| [] ->
let () = assert (i = len) in []
- | (_, None, _) :: sign ->
+ | LocalAssum _ :: sign ->
let () = assert (i < len) in
(Array.unsafe_get args i) :: aux sign (succ i)
- | (_, Some _, _) :: sign ->
+ | LocalDef _ :: sign ->
aux sign (succ i)
in
aux (evar_filtered_context evi) 0
@@ -501,7 +523,8 @@ let solve_pattern_eqn env l c =
match kind_of_term a with
(* Rem: if [a] links to a let-in, do as if it were an assumption *)
| Rel n ->
- let d = map_rel_declaration (lift n) (lookup_rel n env) in
+ let open Context.Rel.Declaration in
+ let d = map_constr (lift n) (lookup_rel n env) in
mkLambda_or_LetIn d c'
| Var id ->
let d = lookup_named id env in mkNamedLambda_or_LetIn d c'
@@ -509,7 +532,7 @@ let solve_pattern_eqn env l c =
l c in
(* Warning: we may miss some opportunity to eta-reduce more since c'
is not in normal form *)
- whd_eta c'
+ shrink_eta c'
(*****************************************)
(* Refining/solving unification problems *)
@@ -530,9 +553,9 @@ let make_projectable_subst aliases sigma evi args =
let evar_aliases = compute_var_aliases sign in
let (_,full_subst,cstr_subst) =
List.fold_right
- (fun (id,b,c) (args,all,cstrs) ->
- match b,args with
- | None, a::rest ->
+ (fun decl (args,all,cstrs) ->
+ match decl,args with
+ | LocalAssum (id,c), a::rest ->
let a = whd_evar sigma a in
let cstrs =
let a',args = decompose_app_vect a in
@@ -542,7 +565,7 @@ let make_projectable_subst aliases sigma evi args =
Constrmap.add (fst cstr) ((args,id)::l) cstrs
| _ -> cstrs in
(rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs)
- | Some c, a::rest ->
+ | LocalDef (id,c,_), a::rest ->
let a = whd_evar sigma a in
(match kind_of_term c with
| Var id' ->
@@ -571,7 +594,9 @@ let make_projectable_subst aliases sigma evi args =
*)
let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env =
- let evd,evar_in_env = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in
+ let evd = Sigma.to_evar_map evd in
let t_in_env = whd_evar evd t_in_env in
let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in
let ctxt = named_context_of_val sign in
@@ -596,16 +621,24 @@ let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_si
* substitution u1..uq.
*)
+exception MorePreciseOccurCheckNeeeded
+
let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
+ if Evd.is_defined evd evk1 then
+ (* Some circularity somewhere (see e.g. #3209) *)
+ raise MorePreciseOccurCheckNeeeded;
+ let (evk1,args1) = destEvar (whd_evar evd (mkEvar (evk1,args1))) in
let evi1 = Evd.find_undefined evd evk1 in
let env1,rel_sign = env_rel_context_chop k env in
let sign1 = evar_hyps evi1 in
let filter1 = evar_filter evi1 in
let src = subterm_source evk1 evi1.evar_source in
- let ids1 = List.map pi1 (named_context_of_val sign1) in
+ let ids1 = List.map get_id (named_context_of_val sign1) in
let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in
+ let open Context.Rel.Declaration in
let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) =
- List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
+ List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
+ let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in
let id = next_name_away na avoid in
let evd,t_in_sign =
let s = Retyping.get_sort_of env evd t_in_env in
@@ -613,13 +646,13 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
~status:univ_flexible (Some false) env evd (mkSort s) in
define_evar_from_virtual_equation define_fun env evd src t_in_env
ty_t_in_sign sign filter inst_in_env in
- let evd,b_in_sign = match b with
- | None -> evd,None
- | Some b ->
+ let evd,b_in_sign = match d with
+ | LocalAssum _ -> evd,None
+ | LocalDef (_,b,_) ->
let evd,b = define_evar_from_virtual_equation define_fun env evd src b
t_in_sign sign filter inst_in_env in
evd,Some b in
- (push_named_context_val (id,b_in_sign,t_in_sign) sign, Filter.extend 1 filter,
+ (push_named_context_val (Context.Named.Declaration.of_tuple (id,b_in_sign,t_in_sign)) sign, Filter.extend 1 filter,
(mkRel 1)::(List.map (lift 1) inst_in_env),
(mkRel 1)::(List.map (lift 1) inst_in_sign),
push_rel d env,evd,id::avoid))
@@ -632,8 +665,10 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
~status:univ_flexible (Some false) env evd (mkSort s) in
define_evar_from_virtual_equation define_fun env evd src ty_in_env
ty_t_in_sign sign2 filter2 inst2_in_env in
- let evd,ev2_in_sign =
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (ev2_in_sign, evd, _) =
new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in
+ let evd = Sigma.to_evar_map evd in
let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in
(evd, ev2_in_sign, ev2_in_env)
@@ -757,9 +792,10 @@ let project_with_effects aliases sigma effects t subst =
effects := p :: !effects;
c
+open Context.Named.Declaration
let rec find_solution_type evarenv = function
- | (id,ProjectVar)::l -> pi3 (lookup_named id evarenv)
- | [id,ProjectEvar _] -> (* bugged *) pi3 (lookup_named id evarenv)
+ | (id,ProjectVar)::l -> get_type (lookup_named id evarenv)
+ | [id,ProjectEvar _] -> (* bugged *) get_type (lookup_named id evarenv)
| (id,ProjectEvar _)::l -> find_solution_type evarenv l
| [] -> assert false
@@ -779,7 +815,7 @@ let rec do_projection_effects define_fun env ty evd = function
let evd = Evd.define evk (mkVar id) evd in
(* TODO: simplify constraints involving evk *)
let evd = do_projection_effects define_fun env ty evd p in
- let ty = whd_betadeltaiota env evd (Lazy.force ty) in
+ let ty = whd_all env evd (Lazy.force ty) in
if not (isSort ty) then
(* Don't try to instantiate if a sort because if evar_concl is an
evar it may commit to a univ level which is not the right
@@ -893,7 +929,7 @@ let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' =
*)
let set_of_evctx l =
- List.fold_left (fun s (id,_,_) -> Id.Set.add id s) Id.Set.empty l
+ List.fold_left (fun s decl -> Id.Set.add (get_id decl) s) Id.Set.empty l
let filter_effective_candidates evi filter candidates =
match filter with
@@ -925,7 +961,13 @@ let closure_of_filter evd evk = function
| Some filter ->
let evi = Evd.find_undefined evd evk in
let vars = collect_vars (Evarutil.nf_evar evd (evar_concl evi)) in
- let test b (id,c,_) = b || Idset.mem id vars || match c with None -> false | Some c -> not (isRel c || isVar c) in
+ let test b decl = b || Idset.mem (get_id decl) vars ||
+ match decl with
+ | LocalAssum _ ->
+ false
+ | LocalDef (_,c,_) ->
+ not (isRel c || isVar c)
+ in
let newfilter = Filter.map_along test filter (evar_context evi) in
(* Now ensure that restriction is at least what is was originally *)
let newfilter = Option.cata (Filter.map_along (&&) newfilter) newfilter (Filter.repr (evar_filter evi)) in
@@ -1007,21 +1049,6 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs =
* Note: argument f is the function used to instantiate evars.
*)
-let are_canonical_instances args1 args2 env =
- let n1 = Array.length args1 in
- let n2 = Array.length args2 in
- let rec aux n = function
- | (id,_,c)::sign
- when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) ->
- aux (n+1) sign
- | [] ->
- let rec aux2 n =
- Int.equal n n1 ||
- (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1))
- in aux2 n
- | _ -> false in
- Int.equal n1 n2 && aux 0 (named_context env)
-
let filter_compatible_candidates conv_algo env evd evi args rhs c =
let c' = instantiate_evar_array evi c args in
match conv_algo env evd Reduction.CONV rhs c' with
@@ -1296,7 +1323,7 @@ let occur_evar_upto_types sigma n c =
seen := Evar.Set.add sp !seen;
Option.iter occur_rec (existential_opt_value sigma e);
occur_rec (existential_type sigma e))
- | _ -> iter_constr occur_rec c
+ | _ -> Constr.iter occur_rec c
in
try occur_rec c; false with Occur -> true
@@ -1381,15 +1408,16 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
let t = whd_evar !evdref t in
match kind_of_term t with
| Rel i when i>k ->
- (match pi2 (Environ.lookup_rel (i-k) env') with
- | None -> project_variable (mkRel (i-k))
- | Some b ->
+ let open Context.Rel.Declaration in
+ (match Environ.lookup_rel (i-k) env' with
+ | LocalAssum _ -> project_variable (mkRel (i-k))
+ | LocalDef (_,b,_) ->
try project_variable (mkRel (i-k))
with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b))
| Var id ->
- (match pi2 (Environ.lookup_named id env') with
- | None -> project_variable t
- | Some b ->
+ (match Environ.lookup_named id env' with
+ | LocalAssum _ -> project_variable t
+ | LocalDef (_,b,_) ->
try project_variable t
with NotInvertibleUsingOurAlgorithm _ -> imitate envk b)
| LetIn (na,b,u,c) ->
@@ -1450,7 +1478,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
imitate envk t in
t::l
- with e when Errors.noncritical e -> l in
+ with e when CErrors.noncritical e -> l in
(match candidates with
| [x] -> x
| _ ->
@@ -1469,7 +1497,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
let names = ref Idset.empty in
let rec is_id_subst ctxt s =
match ctxt, s with
- | ((id, _, _) :: ctxt'), (c :: s') ->
+ | (decl :: ctxt'), (c :: s') ->
+ let id = get_id decl in
names := Idset.add id !names;
isVarId id c && is_id_subst ctxt' s'
| [], [] -> true
@@ -1538,11 +1567,13 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs =
postpone_non_unique_projection env evd pbty ev sols rhs
| NotEnoughInformationEvarEvar t ->
add_conv_oriented_pb (pbty,env,mkEvar ev,t) evd
+ | MorePreciseOccurCheckNeeeded ->
+ add_conv_oriented_pb (pbty,env,mkEvar ev,rhs) evd
| NotInvertibleUsingOurAlgorithm _ | MetaOccurInBodyInternal as e ->
raise e
| OccurCheckIn (evd,rhs) ->
(* last chance: rhs actually reduces to ev *)
- let c = whd_betadeltaiota env evd rhs in
+ let c = whd_all env evd rhs in
match kind_of_term c with
| Evar (evk',argsv2) when Evar.equal evk evk' ->
solve_refl (fun env sigma pb c c' -> is_fconv pb env sigma c c')
@@ -1580,7 +1611,7 @@ let status_changed lev (pbty,_,t1,t2) =
(try Evar.Set.mem (head_evar t1) lev with NoHeadEvar -> false) ||
(try Evar.Set.mem (head_evar t2) lev with NoHeadEvar -> false)
-let reconsider_conv_pbs conv_algo evd =
+let reconsider_unif_constraints conv_algo evd =
let (evd,pbs) = extract_changed_conv_pbs evd status_changed in
List.fold_left
(fun p (pbty,env,t1,t2 as x) ->
@@ -1593,6 +1624,8 @@ let reconsider_conv_pbs conv_algo evd =
(Success evd)
pbs
+let reconsider_conv_pbs = reconsider_unif_constraints
+
(* Tries to solve problem t1 = t2.
* Precondition: t1 is an uninstantiated evar
* Returns an optional list of evars that were instantiated, or None
@@ -1603,7 +1636,7 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1)
try
let t2 = whd_betaiota evd t2 in (* includes whd_evar *)
let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in
- reconsider_conv_pbs conv_algo evd
+ reconsider_unif_constraints conv_algo evd
with
| NotInvertibleUsingOurAlgorithm t ->
UnifFailure (evd,NotClean (ev1,env,t))
diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli
index 918ba12f..b6bdc078 100644
--- a/pretyping/evarsolve.mli
+++ b/pretyping/evarsolve.mli
@@ -34,8 +34,12 @@ type conv_fun_bool =
val evar_define : conv_fun -> ?choose:bool -> env -> evar_map ->
bool option -> existential -> constr -> evar_map
-val refresh_universes : ?status:Evd.rigid ->
- ?onlyalg:bool (* Only algebraic universes *) ->
+val refresh_universes :
+ ?status:Evd.rigid ->
+ ?onlyalg:bool (* Only algebraic universes *) ->
+ ?refreshset:bool ->
+ (* Also refresh Prop and Set universes, so that the returned type can be any supertype
+ of the original type *)
bool option (* direction: true for levels lower than the existing levels *) ->
env -> evar_map -> types -> evar_map * types
@@ -50,7 +54,10 @@ val solve_evar_evar : ?force:bool ->
val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map ->
bool option * existential * constr -> unification_result
+val reconsider_unif_constraints : conv_fun -> evar_map -> unification_result
+
val reconsider_conv_pbs : conv_fun -> evar_map -> unification_result
+(** @deprecated Alias for [reconsider_unif_constraints] *)
val is_unification_pattern_evar : env -> evar_map -> existential -> constr list ->
constr -> constr list option
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
deleted file mode 100644
index e23e5a53..00000000
--- a/pretyping/evarutil.ml
+++ /dev/null
@@ -1,872 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Errors
-open Util
-open Pp
-open Names
-open Term
-open Vars
-open Context
-open Termops
-open Namegen
-open Pre_env
-open Environ
-open Evd
-open Reductionops
-open Pretype_errors
-
-(** Combinators *)
-
-let evd_comb0 f evdref =
- let (evd',x) = f !evdref in
- evdref := evd';
- x
-
-let evd_comb1 f evdref x =
- let (evd',y) = f !evdref x in
- evdref := evd';
- y
-
-let evd_comb2 f evdref x y =
- let (evd',z) = f !evdref x y in
- evdref := evd';
- z
-
-let e_new_global evdref x =
- evd_comb1 (Evd.fresh_global (Global.env())) evdref x
-
-let new_global evd x =
- Evd.fresh_global (Global.env()) evd x
-
-(****************************************************)
-(* Expanding/testing/exposing existential variables *)
-(****************************************************)
-
-(* flush_and_check_evars fails if an existential is undefined *)
-
-exception Uninstantiated_evar of existential_key
-
-let rec flush_and_check_evars sigma c =
- match kind_of_term c with
- | Evar (evk,_ as ev) ->
- (match existential_opt_value sigma ev with
- | None -> raise (Uninstantiated_evar evk)
- | Some c -> flush_and_check_evars sigma c)
- | _ -> map_constr (flush_and_check_evars sigma) c
-
-(* let nf_evar_key = Profile.declare_profile "nf_evar" *)
-(* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *)
-let nf_evar = Reductionops.nf_evar
-let j_nf_evar sigma j =
- { uj_val = nf_evar sigma j.uj_val;
- uj_type = nf_evar sigma j.uj_type }
-let j_nf_betaiotaevar sigma j =
- { uj_val = nf_evar sigma j.uj_val;
- uj_type = Reductionops.nf_betaiota sigma j.uj_type }
-let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl
-let jv_nf_betaiotaevar sigma jl =
- Array.map (j_nf_betaiotaevar sigma) jl
-let jv_nf_evar sigma = Array.map (j_nf_evar sigma)
-let tj_nf_evar sigma {utj_val=v;utj_type=t} =
- {utj_val=nf_evar sigma v;utj_type=t}
-
-let env_nf_evar sigma env =
- process_rel_context
- (fun d e -> push_rel (map_rel_declaration (nf_evar sigma) d) e) env
-
-let env_nf_betaiotaevar sigma env =
- process_rel_context
- (fun d e ->
- push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env
-
-let nf_evars_universes evm =
- Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm)
- (Evd.universe_subst evm)
-
-let nf_evars_and_universes evm =
- let evm = Evd.nf_constraints evm in
- evm, nf_evars_universes evm
-
-let e_nf_evars_and_universes evdref =
- evdref := Evd.nf_constraints !evdref;
- nf_evars_universes !evdref, Evd.universe_subst !evdref
-
-let nf_evar_map_universes evm =
- let evm = Evd.nf_constraints evm in
- let subst = Evd.universe_subst evm in
- if Univ.LMap.is_empty subst then evm, nf_evar evm
- else
- let f = nf_evars_universes evm in
- Evd.raw_map (fun _ -> map_evar_info f) evm, f
-
-let nf_named_context_evar sigma ctx =
- Context.map_named_context (nf_evar sigma) ctx
-
-let nf_rel_context_evar sigma ctx =
- Context.map_rel_context (nf_evar sigma) ctx
-
-let nf_env_evar sigma env =
- let nc' = nf_named_context_evar sigma (Environ.named_context env) in
- let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in
- push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env)
-
-let nf_evar_info evc info = map_evar_info (nf_evar evc) info
-
-let nf_evar_map evm =
- Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm
-
-let nf_evar_map_undefined evm =
- Evd.raw_map_undefined (fun _ evi -> nf_evar_info evm evi) evm
-
-(*-------------------*)
-(* Auxiliary functions for the conversion algorithms modulo evars
- *)
-
-(* A probably faster though more approximative variant of
- [has_undefined (nf_evar c)]: instances are not substituted and
- maybe an evar occurs in an instance and it would disappear by
- instantiation *)
-
-let has_undefined_evars evd t =
- let rec has_ev t =
- match kind_of_term t with
- | Evar (ev,args) ->
- (match evar_body (Evd.find evd ev) with
- | Evar_defined c ->
- has_ev c; Array.iter has_ev args
- | Evar_empty ->
- raise NotInstantiatedEvar)
- | _ -> iter_constr has_ev t in
- try let _ = has_ev t in false
- with (Not_found | NotInstantiatedEvar) -> true
-
-let is_ground_term evd t =
- not (has_undefined_evars evd t)
-
-let is_ground_env evd env =
- let is_ground_decl = function
- (_,Some b,_) -> is_ground_term evd b
- | _ -> true in
- List.for_all is_ground_decl (rel_context env) &&
- List.for_all is_ground_decl (named_context env)
-
-(* Memoization is safe since evar_map and environ are applicative
- structures *)
-let memo f =
- let m = ref None in
- fun x y -> match !m with
- | Some (x', y', r) when x == x' && y == y' -> r
- | _ -> let r = f x y in m := Some (x, y, r); r
-
-let is_ground_env = memo is_ground_env
-
-(* Return the head evar if any *)
-
-exception NoHeadEvar
-
-let head_evar =
- let rec hrec c = match kind_of_term c with
- | Evar (evk,_) -> evk
- | Case (_,_,c,_) -> hrec c
- | App (c,_) -> hrec c
- | Cast (c,_,_) -> hrec c
- | _ -> raise NoHeadEvar
- in
- hrec
-
-(* Expand head evar if any (currently consider only applications but I
- guess it should consider Case too) *)
-
-let whd_head_evar_stack sigma c =
- let rec whrec (c, l as s) =
- match kind_of_term c with
- | Evar (evk,args as ev) ->
- let v =
- try Some (existential_value sigma ev)
- with NotInstantiatedEvar | Not_found -> None in
- begin match v with
- | None -> s
- | Some c -> whrec (c, l)
- end
- | Cast (c,_,_) -> whrec (c, l)
- | App (f,args) -> whrec (f, args :: l)
- | _ -> s
- in
- whrec (c, [])
-
-let whd_head_evar sigma c =
- let (f, args) = whd_head_evar_stack sigma c in
- (** optim: don't reallocate if empty/singleton *)
- match args with
- | [] -> f
- | [arg] -> mkApp (f, arg)
- | _ -> mkApp (f, Array.concat args)
-
-(**********************)
-(* Creating new metas *)
-(**********************)
-
-let meta_counter_summary_name = "meta counter"
-
-(* Generator of metavariables *)
-let new_meta =
- let meta_ctr = Summary.ref 0 ~name:meta_counter_summary_name in
- fun () -> incr meta_ctr; !meta_ctr
-
-let mk_new_meta () = mkMeta(new_meta())
-
-(* The list of non-instantiated existential declarations (order is important) *)
-
-let non_instantiated sigma =
- let listev = Evd.undefined_map sigma in
- Evar.Map.smartmap (fun evi -> nf_evar_info sigma evi) listev
-
-(************************)
-(* Manipulating filters *)
-(************************)
-
-let make_pure_subst evi args =
- snd (List.fold_right
- (fun (id,b,c) (args,l) ->
- match args with
- | a::rest -> (rest, (id,a)::l)
- | _ -> anomaly (Pp.str "Instance does not match its signature"))
- (evar_filtered_context evi) (Array.rev_to_list args,[]))
-
-(**********************)
-(* Creating new evars *)
-(**********************)
-
-let evar_counter_summary_name = "evar counter"
-
-(* Generator of existential names *)
-let new_untyped_evar =
- let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in
- fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr
-
-(*------------------------------------*
- * functional operations on evar sets *
- *------------------------------------*)
-
-(* [push_rel_context_to_named_context] builds the defining context and the
- * initial instance of an evar. If the evar is to be used in context
- *
- * Gamma = a1 ... an xp ... x1
- * \- named part -/ \- de Bruijn part -/
- *
- * then the x1...xp are turned into variables so that the evar is declared in
- * context
- *
- * a1 ... an xp ... x1
- * \----------- named part ------------/
- *
- * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)"
- * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed
- * in context Gamma.
- *
- * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first)
- * Remark 2: If some of the ai or xj are definitions, we keep them in the
- * instance. This is necessary so that no unfolding of local definitions
- * happens when inferring implicit arguments (consider e.g. the problem
- * "x:nat; x':=x; f:forall y, y=y -> Prop |- f _ (refl_equal x')" which
- * produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want
- * the hole to be instantiated by x', not by x (which would have been
- * the case in [invert_definition] if x' had disappeared from the instance).
- * Note that at any time, if, in some context env, the instance of
- * declaration x:A is t and the instance of definition x':=phi(x) is u, then
- * we have the property that u and phi(t) are convertible in env.
- *)
-
-let subst2 subst vsubst c =
- substl subst (replace_vars vsubst c)
-
-let push_rel_context_to_named_context env typ =
- (* compute the instances relative to the named context and rel_context *)
- let ids = List.map pi1 (named_context env) in
- let inst_vars = List.map mkVar ids in
- let inst_rels = List.rev (rel_list 0 (nb_rel env)) in
- let replace_var_named_declaration id0 id (id',b,t) =
- let id' = if Id.equal id0 id' then id else id' in
- let vsubst = [id0 , mkVar id] in
- let b = match b with
- | None -> None
- | Some c -> Some (replace_vars vsubst c)
- in
- id', b, replace_vars vsubst t
- in
- let replace_var_named_context id0 id env =
- let nc = Environ.named_context env in
- let nc' = List.map (replace_var_named_declaration id0 id) nc in
- Environ.reset_with_named_context (val_of_named_context nc') env
- in
- let extract_if_neq id = function
- | Anonymous -> None
- | Name id' when id_ord id id' = 0 -> None
- | Name id' -> Some id'
- in
- (* move the rel context to a named context and extend the named instance *)
- (* with vars of the rel context *)
- (* We do keep the instances corresponding to local definition (see above) *)
- let (subst, vsubst, _, env) =
- Context.fold_rel_context
- (fun (na,c,t) (subst, vsubst, avoid, env) ->
- let id =
- (* ppedrot: we want to infer nicer names for the refine tactic, but
- keeping at the same time backward compatibility in other code
- using this function. For now, we only attempt to preserve the
- old behaviour of Program, but ultimately, one should do something
- about this whole name generation problem. *)
- if Flags.is_program_mode () then next_name_away na avoid
- else next_ident_away (id_of_name_using_hdchar env t na) avoid
- in
- match extract_if_neq id na with
- | Some id0 when not (is_section_variable id0) ->
- (* spiwack: if [id<>id0], rather than introducing a new
- binding named [id], we will keep [id0] (the name given
- by the user) and rename [id0] into [id] in the named
- context. Unless [id] is a section variable. *)
- let subst = List.map (replace_vars [id0,mkVar id]) subst in
- let vsubst = (id0,mkVar id)::vsubst in
- let d = (id0, Option.map (subst2 subst vsubst) c, subst2 subst vsubst t) in
- let env = replace_var_named_context id0 id env in
- (mkVar id0 :: subst, vsubst, id::avoid, push_named d env)
- | _ ->
- (* spiwack: if [id0] is a section variable renaming it is
- incorrect. We revert to a less robust behaviour where
- the new binder has name [id]. Which amounts to the same
- behaviour than when [id=id0]. *)
- let d = (id,Option.map (subst2 subst vsubst) c,subst2 subst vsubst t) in
- (mkVar id :: subst, vsubst, id::avoid, push_named d env)
- )
- (rel_context env) ~init:([], [], ids, env) in
- (named_context_val env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst)
-
-(*------------------------------------*
- * Entry points to define new evars *
- *------------------------------------*)
-
-let default_source = (Loc.ghost,Evar_kinds.InternalHole)
-
-let restrict_evar evd evk filter candidates =
- let evk' = new_untyped_evar () in
- let evd = Evd.restrict evk evk' filter ?candidates evd in
- Evd.declare_future_goal evk' evd, evk'
-
-let new_pure_evar_full evd evi =
- let evk = new_untyped_evar () in
- let evd = Evd.add evd evk evi in
- let evd = Evd.declare_future_goal evk evd in
- (evd, evk)
-
-let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?naming ?(principal=false) typ =
- let default_naming =
- if principal then
- (* waiting for a more principled approach
- (unnamed evars, private names?) *)
- Misctypes.IntroFresh (Names.Id.of_string "tmp_goal")
- else
- Misctypes.IntroAnonymous
- in
- let naming = Option.default default_naming naming in
- let newevk = new_untyped_evar() in
- let evd = evar_declare sign newevk typ ~src ?filter ?candidates ?store ~naming evd in
- let evd =
- if principal then Evd.declare_principal_goal newevk evd
- else Evd.declare_future_goal newevk evd
- in
- (evd,newevk)
-
-let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance =
- assert (not !Flags.debug ||
- List.distinct (ids_of_named_context (named_context_of_val sign)));
- let evd,newevk = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in
- (evd,mkEvar (newevk,Array.of_list instance))
-
-(* [new_evar] declares a new existential in an env env with type typ *)
-(* Converting the env into the sign of the evar to define *)
-let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
- let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in
- let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in
- let instance =
- match filter with
- | None -> instance
- | Some filter -> Filter.filter_list filter instance in
- new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance
-
-let new_type_evar env evd ?src ?filter ?naming ?principal rigid =
- let evd', s = new_sort_variable rigid evd in
- let evd', e = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in
- evd', (e, s)
-
-let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid =
- let evd', c = new_type_evar env !evdref ?src ?filter ?naming ?principal rigid in
- evdref := evd';
- c
-
-let new_Type ?(rigid=Evd.univ_flexible) env evd =
- let evd', s = new_sort_variable rigid evd in
- evd', mkSort s
-
-let e_new_Type ?(rigid=Evd.univ_flexible) env evdref =
- let evd', s = new_sort_variable rigid !evdref in
- evdref := evd'; mkSort s
-
- (* The same using side-effect *)
-let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty =
- let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in
- evdref := evd';
- ev
-
-(* This assumes an evar with identity instance and generalizes it over only
- the De Bruijn part of the context *)
-let generalize_evar_over_rels sigma (ev,args) =
- let evi = Evd.find sigma ev in
- let sign = named_context_of_val evi.evar_hyps in
- List.fold_left2
- (fun (c,inst as x) a d ->
- if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x)
- (evi.evar_concl,[]) (Array.to_list args) sign
-
-(************************************)
-(* Removing a dependency in an evar *)
-(************************************)
-
-type clear_dependency_error =
-| OccurHypInSimpleClause of Id.t option
-| EvarTypingBreak of existential
-
-exception ClearDependencyError of Id.t * clear_dependency_error
-
-let cleared = Store.field ()
-
-exception Depends of Id.t
-
-let rec check_and_clear_in_constr env evdref err ids c =
- (* returns a new constr where all the evars have been 'cleaned'
- (ie the hypotheses ids have been removed from the contexts of
- evars) *)
- let check id' =
- if Id.Set.mem id' ids then
- raise (ClearDependencyError (id',err))
- in
- match kind_of_term c with
- | Var id' ->
- check id'; c
-
- | ( Const _ | Ind _ | Construct _ ) ->
- let vars = Environ.vars_of_global env c in
- Id.Set.iter check vars; c
-
- | Evar (evk,l as ev) ->
- if Evd.is_defined !evdref evk then
- (* If evk is already defined we replace it by its definition *)
- let nc = whd_evar !evdref c in
- (check_and_clear_in_constr env evdref err ids nc)
- else
- (* We check for dependencies to elements of ids in the
- evar_info corresponding to e and in the instance of
- arguments. Concurrently, we build a new evar
- corresponding to e where hypotheses of ids have been
- removed *)
- let evi = Evd.find_undefined !evdref evk in
- let ctxt = Evd.evar_filtered_context evi in
- let (rids,filter) =
- List.fold_right2
- (fun (rid, ob,c as h) a (ri,filter) ->
- try
- (* Check if some id to clear occurs in the instance
- a of rid in ev and remember the dependency *)
- let check id = if Id.Set.mem id ids then raise (Depends id) in
- let () = Id.Set.iter check (collect_vars a) in
- (* Check if some rid to clear in the context of ev
- has dependencies in another hyp of the context of ev
- and transitively remember the dependency *)
- let check id _ =
- if occur_var_in_decl (Global.env ()) id h
- then raise (Depends id)
- in
- let () = Id.Map.iter check ri in
- (* No dependency at all, we can keep this ev's context hyp *)
- (ri, true::filter)
- with Depends id -> (Id.Map.add rid id ri, false::filter))
- ctxt (Array.to_list l) (Id.Map.empty,[]) in
- (* Check if some rid to clear in the context of ev has dependencies
- in the type of ev and adjust the source of the dependency *)
- let _nconcl =
- try
- let nids = Id.Map.domain rids in
- check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids (evar_concl evi)
- with ClearDependencyError (rid,err) ->
- raise (ClearDependencyError (Id.Map.find rid rids,err)) in
-
- if Id.Map.is_empty rids then c
- else
- let origfilter = Evd.evar_filter evi in
- let filter = Evd.Filter.apply_subfilter origfilter filter in
- let evd,_ = restrict_evar !evdref evk filter None in
- evdref := evd;
- (* spiwack: hacking session to mark the old [evk] as having been "cleared" *)
- let evi = Evd.find !evdref evk in
- let extra = evi.evar_extra in
- let extra' = Store.set extra cleared true in
- let evi' = { evi with evar_extra = extra' } in
- evdref := Evd.add !evdref evk evi' ;
- (* spiwack: /hacking session *)
- whd_evar !evdref c
-
- | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c
-
-let clear_hyps_in_evi_main env evdref hyps terms ids =
- (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some
- hypothesis does not depend on a element of ids, and erases ids in
- the contexts of the evars occurring in evi *)
- let terms =
- List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in
- let nhyps =
- let check_context ((id,ob,c) as decl) =
- let err = OccurHypInSimpleClause (Some id) in
- let ob' = Option.smartmap (fun c -> check_and_clear_in_constr env evdref err ids c) ob in
- let c' = check_and_clear_in_constr env evdref err ids c in
- if ob == ob' && c == c' then decl else (id, ob', c')
- in
- let check_value vk = match force_lazy_val vk with
- | None -> vk
- | Some (_, d) ->
- if (Id.Set.for_all (fun e -> not (Id.Set.mem e d)) ids) then
- (* v does depend on any of ids, it's ok *)
- vk
- else
- (* v depends on one of the cleared hyps:
- we forget the computed value *)
- dummy_lazy_val ()
- in
- remove_hyps ids check_context check_value hyps
- in
- (nhyps,terms)
-
-let clear_hyps_in_evi env evdref hyps concl ids =
- match clear_hyps_in_evi_main env evdref hyps [concl] ids with
- | (nhyps,[nconcl]) -> (nhyps,nconcl)
- | _ -> assert false
-
-let clear_hyps2_in_evi env evdref hyps t concl ids =
- match clear_hyps_in_evi_main env evdref hyps [t;concl] ids with
- | (nhyps,[t;nconcl]) -> (nhyps,t,nconcl)
- | _ -> assert false
-
-(* spiwack: a few functions to gather evars on which goals depend. *)
-let queue_set q is_dependent set =
- Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set
-let queue_term q is_dependent c =
- queue_set q is_dependent (evars_of_term c)
-
-let process_dependent_evar q acc evm is_dependent e =
- let evi = Evd.find evm e in
- (* Queues evars appearing in the types of the goal (conclusion, then
- hypotheses), they are all dependent. *)
- queue_term q true evi.evar_concl;
- List.iter begin fun (_,b,t) ->
- queue_term q true t;
- match b with
- | None -> ()
- | Some b -> queue_term q true b
- end (Environ.named_context_of_val evi.evar_hyps);
- match evi.evar_body with
- | Evar_empty ->
- if is_dependent then Evar.Map.add e None acc else acc
- | Evar_defined b ->
- let subevars = evars_of_term b in
- (* evars appearing in the definition of an evar [e] are marked
- as dependent when [e] is dependent itself: if [e] is a
- non-dependent goal, then, unless they are reach from another
- path, these evars are just other non-dependent goals. *)
- queue_set q is_dependent subevars;
- if is_dependent then Evar.Map.add e (Some subevars) acc else acc
-
-let gather_dependent_evars q evm =
- let acc = ref Evar.Map.empty in
- while not (Queue.is_empty q) do
- let (is_dependent,e) = Queue.pop q in
- (* checks if [e] has already been added to [!acc] *)
- begin if not (Evar.Map.mem e !acc) then
- acc := process_dependent_evar q !acc evm is_dependent e
- end
- done;
- !acc
-
-let gather_dependent_evars evm l =
- let q = Queue.create () in
- List.iter (fun a -> Queue.add (false,a) q) l;
- gather_dependent_evars q evm
-
-(* /spiwack *)
-
-(** The following functions return the set of undefined evars
- contained in the object, the defined evars being traversed.
- This is roughly a combination of the previous functions and
- [nf_evar]. *)
-
-let undefined_evars_of_term evd t =
- let rec evrec acc c =
- match kind_of_term c with
- | Evar (n, l) ->
- let acc = Array.fold_left evrec acc l in
- (try match (Evd.find evd n).evar_body with
- | Evar_empty -> Evar.Set.add n acc
- | Evar_defined c -> evrec acc c
- with Not_found -> anomaly ~label:"undefined_evars_of_term" (Pp.str "evar not found"))
- | _ -> fold_constr evrec acc c
- in
- evrec Evar.Set.empty t
-
-let undefined_evars_of_named_context evd nc =
- List.fold_right (fun (_, b, t) s ->
- Option.fold_left (fun s t ->
- Evar.Set.union s (undefined_evars_of_term evd t))
- (Evar.Set.union s (undefined_evars_of_term evd t)) b)
- nc Evar.Set.empty
-
-let undefined_evars_of_evar_info evd evi =
- Evar.Set.union (undefined_evars_of_term evd evi.evar_concl)
- (Evar.Set.union
- (match evi.evar_body with
- | Evar_empty -> Evar.Set.empty
- | Evar_defined b -> undefined_evars_of_term evd b)
- (undefined_evars_of_named_context evd
- (named_context_of_val evi.evar_hyps)))
-
-(* [check_evars] fails if some unresolved evar remains *)
-
-let check_evars env initial_sigma sigma c =
- let rec proc_rec c =
- match kind_of_term c with
- | Evar (evk,_ as ev) ->
- (match existential_opt_value sigma ev with
- | Some c -> proc_rec c
- | None ->
- if not (Evd.mem initial_sigma evk) then
- let (loc,k) = evar_source evk sigma in
- match k with
- | Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
- | _ -> error_unsolvable_implicit loc env sigma evk None)
- | _ -> iter_constr proc_rec c
- in proc_rec c
-
-(* spiwack: this is a more complete version of
- {!Termops.occur_evar}. The latter does not look recursively into an
- [evar_map]. If unification only need to check superficially, tactics
- do not have this luxury, and need the more complete version. *)
-let occur_evar_upto sigma n c =
- let rec occur_rec c = match kind_of_term c with
- | Evar (sp,_) when Evar.equal sp n -> raise Occur
- | Evar e -> Option.iter occur_rec (existential_opt_value sigma e)
- | _ -> iter_constr occur_rec c
- in
- try occur_rec c; false with Occur -> true
-
-
-(****************************************)
-(* Operations on value/type constraints *)
-(****************************************)
-
-type type_constraint = types option
-
-type val_constraint = constr option
-
-(* Old comment...
- * Basically, we have the following kind of constraints (in increasing
- * strength order):
- * (false,(None,None)) -> no constraint at all
- * (true,(None,None)) -> we must build a judgement which _TYPE is a kind
- * (_,(None,Some ty)) -> we must build a judgement which _TYPE is ty
- * (_,(Some v,_)) -> we must build a judgement which _VAL is v
- * Maybe a concrete datatype would be easier to understand.
- * We differentiate (true,(None,None)) from (_,(None,Some Type))
- * because otherwise Case(s) would be misled, as in
- * (n:nat) Case n of bool [_]nat end would infer the predicate Type instead
- * of Set.
- *)
-
-(* The empty type constraint *)
-let empty_tycon = None
-
-(* Builds a type constraint *)
-let mk_tycon ty = Some ty
-
-(* Constrains the value of a type *)
-let empty_valcon = None
-
-(* Builds a value constraint *)
-let mk_valcon c = Some c
-
-let idx = Namegen.default_dependent_ident
-
-(* Refining an evar to a product *)
-
-let define_pure_evar_as_product evd evk =
- let evi = Evd.find_undefined evd evk in
- let evenv = evar_env evi in
- let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
- let concl = whd_betadeltaiota evenv evd evi.evar_concl in
- let s = destSort concl in
- let evd1,(dom,u1) =
- new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
- let evd2,rng =
- let newenv = push_named (id, None, dom) evenv in
- let src = evar_source evk evd1 in
- let filter = Filter.extend 1 (evar_filter evi) in
- if is_prop_sort s then
- (* Impredicative product, conclusion must fall in [Prop]. *)
- new_evar newenv evd1 concl ~src ~filter
- else
- let status = univ_flexible_alg in
- let evd3, (rng, srng) =
- new_type_evar newenv evd1 status ~src ~filter in
- let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in
- let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in
- evd3, rng
- in
- let prod = mkProd (Name id, dom, subst_var id rng) in
- let evd3 = Evd.define evk prod evd2 in
- evd3,prod
-
-(* Refine an applied evar to a product and returns its instantiation *)
-
-let define_evar_as_product evd (evk,args) =
- let evd,prod = define_pure_evar_as_product evd evk in
- (* Quick way to compute the instantiation of evk with args *)
- let na,dom,rng = destProd prod in
- let evdom = mkEvar (fst (destEvar dom), args) in
- let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
- let evrng = mkEvar (fst (destEvar rng), evrngargs) in
- evd,mkProd (na, evdom, evrng)
-
-(* Refine an evar with an abstraction
-
- I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where:
- - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y)
- or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B
- with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type
- - x1..xq,y:A |- ?e':B
-*)
-
-let define_pure_evar_as_lambda env evd evk =
- let evi = Evd.find_undefined evd evk in
- let evenv = evar_env evi in
- let typ = whd_betadeltaiota evenv evd (evar_concl evi) in
- let evd1,(na,dom,rng) = match kind_of_term typ with
- | Prod (na,dom,rng) -> (evd,(na,dom,rng))
- | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ
- | _ -> error_not_product_loc Loc.ghost env evd typ in
- let avoid = ids_of_named_context (evar_context evi) in
- let id =
- next_name_away_with_default_using_types "x" na avoid (whd_evar evd dom) in
- let newenv = push_named (id, None, dom) evenv in
- let filter = Filter.extend 1 (evar_filter evi) in
- let src = evar_source evk evd1 in
- let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
- let lam = mkLambda (Name id, dom, subst_var id body) in
- Evd.define evk lam evd2, lam
-
-let define_evar_as_lambda env evd (evk,args) =
- let evd,lam = define_pure_evar_as_lambda env evd evk in
- (* Quick way to compute the instantiation of evk with args *)
- let na,dom,body = destLambda lam in
- let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
- let evbody = mkEvar (fst (destEvar body), evbodyargs) in
- evd,mkLambda (na, dom, evbody)
-
-let rec evar_absorb_arguments env evd (evk,args as ev) = function
- | [] -> evd,ev
- | a::l ->
- (* TODO: optimize and avoid introducing intermediate evars *)
- let evd,lam = define_pure_evar_as_lambda env evd evk in
- let _,_,body = destLambda lam in
- let evk = fst (destEvar body) in
- evar_absorb_arguments env evd (evk, Array.cons a args) l
-
-(* Refining an evar to a sort *)
-
-let define_evar_as_sort env evd (ev,args) =
- let evd, u = new_univ_variable univ_rigid evd in
- let evi = Evd.find_undefined evd ev in
- let s = Type u in
- let concl = whd_betadeltaiota (evar_env evi) evd evi.evar_concl in
- let sort = destSort concl in
- let evd' = Evd.define ev (mkSort s) evd in
- Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s
-
-(* We don't try to guess in which sort the type should be defined, since
- any type has type Type. May cause some trouble, but not so far... *)
-
-let judge_of_new_Type evd =
- let evd', s = new_univ_variable univ_rigid evd in
- evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }
-
-(* Propagation of constraints through application and abstraction:
- Given a type constraint on a functional term, returns the type
- constraint on its domain and codomain. If the input constraint is
- an evar instantiate it with the product of 2 new evars. *)
-
-let split_tycon loc env evd tycon =
- let rec real_split evd c =
- let t = whd_betadeltaiota env evd c in
- match kind_of_term t with
- | Prod (na,dom,rng) -> evd, (na, dom, rng)
- | Evar ev (* ev is undefined because of whd_betadeltaiota *) ->
- let (evd',prod) = define_evar_as_product evd ev in
- let (_,dom,rng) = destProd prod in
- evd',(Anonymous, dom, rng)
- | App (c,args) when isEvar c ->
- let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in
- real_split evd' (mkApp (lam,args))
- | _ -> error_not_product_loc loc env evd c
- in
- match tycon with
- | None -> evd,(Anonymous,None,None)
- | Some c ->
- let evd', (n, dom, rng) = real_split evd c in
- evd', (n, mk_tycon dom, mk_tycon rng)
-
-let valcon_of_tycon x = x
-let lift_tycon n = Option.map (lift n)
-
-let pr_tycon env = function
- None -> str "None"
- | Some t -> Termops.print_constr_env env t
-
-let subterm_source evk (loc,k) =
- let evk = match k with
- | Evar_kinds.SubEvar (evk) -> evk
- | _ -> evk in
- (loc,Evar_kinds.SubEvar evk)
-
-
-(** Term exploration up to instantiation. *)
-let kind_of_term_upto sigma t =
- Constr.kind (Reductionops.whd_evar sigma t)
-
-(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and
- [u] up to existential variable instantiation and equalisable
- universes. The term [t] is interpreted in [sigma1] while [u] is
- interpreted in [sigma2]. The universe constraints in [sigma2] are
- assumed to be an extention of those in [sigma1]. *)
-let eq_constr_univs_test sigma1 sigma2 t u =
- (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *)
- let open Evd in
- let b, c =
- Universes.eq_constr_univs_infer_with
- (fun t -> kind_of_term_upto sigma1 t)
- (fun u -> kind_of_term_upto sigma2 u)
- (universes sigma2) t u
- in
- if b then
- try let _ = add_universe_constraints sigma2 c in true
- with Univ.UniverseInconsistency _ | UniversesDiffer -> false
- else false
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
deleted file mode 100644
index f68651a7..00000000
--- a/pretyping/evarutil.mli
+++ /dev/null
@@ -1,255 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open Term
-open Context
-open Evd
-open Environ
-
-(** {5 This modules provides useful functions for unification modulo evars } *)
-
-(** {6 Metas} *)
-
-(** [new_meta] is a generator of unique meta variables *)
-val new_meta : unit -> metavariable
-val mk_new_meta : unit -> constr
-
-(** {6 Creating a fresh evar given their type and context} *)
-val new_evar :
- env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
- ?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
- ?principal:bool -> types -> evar_map * constr
-
-val new_pure_evar :
- named_context_val -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
- ?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
- ?principal:bool -> types -> evar_map * evar
-
-val new_pure_evar_full : evar_map -> evar_info -> evar_map * evar
-
-(** the same with side-effects *)
-val e_new_evar :
- env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
- ?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr ->
- ?principal:bool -> types -> constr
-
-(** Create a new Type existential variable, as we keep track of
- them during type-checking and unification. *)
-val new_type_evar :
- env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
- ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid ->
- evar_map * (constr * sorts)
-
-val e_new_type_evar : env -> evar_map ref ->
- ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
- ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts
-
-val new_Type : ?rigid:rigid -> env -> evar_map -> evar_map * constr
-val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr
-
-val restrict_evar : evar_map -> existential_key -> Filter.t ->
- constr list option -> evar_map * existential_key
-
-(** Polymorphic constants *)
-
-val new_global : evar_map -> Globnames.global_reference -> evar_map * constr
-val e_new_global : evar_map ref -> Globnames.global_reference -> constr
-
-(** Create a fresh evar in a context different from its definition context:
- [new_evar_instance sign evd ty inst] creates a new evar of context
- [sign] and type [ty], [inst] is a mapping of the evar context to
- the context where the evar should occur. This means that the terms
- of [inst] are typed in the occurrence context and their type (seen
- as a telescope) is [sign] *)
-val new_evar_instance :
- named_context_val -> evar_map -> types ->
- ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list ->
- ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr ->
- ?principal:bool ->
- constr list -> evar_map * constr
-
-val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list
-
-(** {6 Evars/Metas switching...} *)
-
-val non_instantiated : evar_map -> evar_info Evar.Map.t
-
-(** {6 Unification utils} *)
-
-(** [head_evar c] returns the head evar of [c] if any *)
-exception NoHeadEvar
-val head_evar : constr -> existential_key (** may raise NoHeadEvar *)
-
-(* Expand head evar if any *)
-val whd_head_evar : evar_map -> constr -> constr
-
-(* An over-approximation of [has_undefined (nf_evars evd c)] *)
-val has_undefined_evars : evar_map -> constr -> bool
-
-val is_ground_term : evar_map -> constr -> bool
-val is_ground_env : evar_map -> env -> bool
-(** [check_evars env initial_sigma extended_sigma c] fails if some
- new unresolved evar remains in [c] *)
-val check_evars : env -> evar_map -> evar_map -> constr -> unit
-
-val define_evar_as_product : evar_map -> existential -> evar_map * types
-val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types
-val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts
-
-(** Instantiate an evar by as many lambda's as needed so that its arguments
- are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into
- [?y[vars1:=args1,vars:=args]] with
- [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *)
-val evar_absorb_arguments : env -> evar_map -> existential -> constr list ->
- evar_map * existential
-
-(** [gather_dependent_evars evm seeds] classifies the evars in [evm]
- as dependent_evars and goals (these may overlap). A goal is an
- evar in [seeds] or an evar appearing in the (partial) definition
- of a goal. A dependent evar is an evar appearing in the type
- (hypotheses and conclusion) of a goal, or in the type or (partial)
- definition of a dependent evar. The value return is a map
- associating to each dependent evar [None] if it has no (partial)
- definition or [Some s] if [s] is the list of evars appearing in
- its (partial) definition. *)
-val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.Map.t
-
-(** The following functions return the set of undefined evars
- contained in the object, the defined evars being traversed.
- This is roughly a combination of the previous functions and
- [nf_evar]. *)
-
-val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t
-val undefined_evars_of_named_context : evar_map -> named_context -> Evar.Set.t
-val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t
-
-(** [occur_evar_upto sigma k c] returns [true] if [k] appears in
- [c]. It looks up recursively in [sigma] for the value of existential
- variables. *)
-val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool
-
-(** {6 Value/Type constraints} *)
-
-val judge_of_new_Type : evar_map -> evar_map * unsafe_judgment
-
-type type_constraint = types option
-type val_constraint = constr option
-
-val empty_tycon : type_constraint
-val mk_tycon : constr -> type_constraint
-val empty_valcon : val_constraint
-val mk_valcon : constr -> val_constraint
-
-val split_tycon :
- Loc.t -> env -> evar_map -> type_constraint ->
- evar_map * (Name.t * type_constraint * type_constraint)
-
-val valcon_of_tycon : type_constraint -> val_constraint
-val lift_tycon : int -> type_constraint -> type_constraint
-
-(***********************************************************)
-
-(** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains
- uninstantiated; [nf_evar] leaves uninstantiated evars as is *)
-
-val nf_evar : evar_map -> constr -> constr
-val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment
-val jl_nf_evar :
- evar_map -> unsafe_judgment list -> unsafe_judgment list
-val jv_nf_evar :
- evar_map -> unsafe_judgment array -> unsafe_judgment array
-val tj_nf_evar :
- evar_map -> unsafe_type_judgment -> unsafe_type_judgment
-
-val nf_named_context_evar : evar_map -> named_context -> named_context
-val nf_rel_context_evar : evar_map -> rel_context -> rel_context
-val nf_env_evar : evar_map -> env -> env
-
-val nf_evar_info : evar_map -> evar_info -> evar_info
-val nf_evar_map : evar_map -> evar_map
-val nf_evar_map_undefined : evar_map -> evar_map
-
-val env_nf_evar : evar_map -> env -> env
-val env_nf_betaiotaevar : evar_map -> env -> env
-
-val j_nf_betaiotaevar : evar_map -> unsafe_judgment -> unsafe_judgment
-val jv_nf_betaiotaevar :
- evar_map -> unsafe_judgment array -> unsafe_judgment array
-(** Presenting terms without solved evars *)
-
-val nf_evars_universes : evar_map -> constr -> constr
-
-val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr)
-val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst
-
-(** Normalize the evar map w.r.t. universes, after simplification of constraints.
- Return the substitution function for constrs as well. *)
-val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr)
-
-(** Replacing all evars, possibly raising [Uninstantiated_evar] *)
-exception Uninstantiated_evar of existential_key
-val flush_and_check_evars : evar_map -> constr -> constr
-
-(** {6 Term manipulation up to instantiation} *)
-
-(** Like {!Constr.kind} except that [kind_of_term sigma t] exposes [t]
- as an evar [e] only if [e] is uninstantiated in [sigma]. Otherwise the
- value of [e] in [sigma] is (recursively) used. *)
-val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term
-
-(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and
- [u] up to existential variable instantiation and equalisable
- universes. The term [t] is interpreted in [sigma1] while [u] is
- interpreted in [sigma2]. The universe constraints in [sigma2] are
- assumed to be an extention of those in [sigma1]. *)
-val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool
-
-(** {6 debug pretty-printer:} *)
-
-val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
-
-
-(** {6 Removing hyps in evars'context}
-raise OccurHypInSimpleClause if the removal breaks dependencies *)
-
-type clear_dependency_error =
-| OccurHypInSimpleClause of Id.t option
-| EvarTypingBreak of existential
-
-exception ClearDependencyError of Id.t * clear_dependency_error
-
-(* spiwack: marks an evar that has been "defined" by clear.
- used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*)
-val cleared : bool Store.field
-
-val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types ->
- Id.Set.t -> named_context_val * types
-
-val clear_hyps2_in_evi : env -> evar_map ref -> named_context_val -> types -> types ->
- Id.Set.t -> named_context_val * types * types
-
-val push_rel_context_to_named_context : Environ.env -> types ->
- named_context_val * types * constr list * constr list * (identifier*constr) list
-
-val generalize_evar_over_rels : evar_map -> existential -> types * constr list
-
-(** Evar combinators *)
-
-val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a
-val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a
-val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a
-
-val subterm_source : existential_key -> Evar_kinds.t Loc.located ->
- Evar_kinds.t Loc.located
-
-val meta_counter_summary_name : string
-val evar_counter_summary_name : string
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
deleted file mode 100644
index 01083142..00000000
--- a/pretyping/evd.ml
+++ /dev/null
@@ -1,1908 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Errors
-open Util
-open Names
-open Nameops
-open Term
-open Vars
-open Termops
-open Environ
-open Globnames
-
-(** Generic filters *)
-module Filter :
-sig
- type t
- val equal : t -> t -> bool
- val identity : t
- val filter_list : t -> 'a list -> 'a list
- val filter_array : t -> 'a array -> 'a array
- val extend : int -> t -> t
- val compose : t -> t -> t
- val apply_subfilter : t -> bool list -> t
- val restrict_upon : t -> int -> (int -> bool) -> t option
- val map_along : (bool -> 'a -> bool) -> t -> 'a list -> t
- val make : bool list -> t
- val repr : t -> bool list option
-end =
-struct
- type t = bool list option
- (** We guarantee through the interface that if a filter is [Some _] then it
- contains at least one [false] somewhere. *)
-
- let identity = None
-
- let rec equal l1 l2 = match l1, l2 with
- | [], [] -> true
- | h1 :: l1, h2 :: l2 ->
- (if h1 then h2 else not h2) && equal l1 l2
- | _ -> false
-
- let equal l1 l2 = match l1, l2 with
- | None, None -> true
- | Some _, None | None, Some _ -> false
- | Some l1, Some l2 -> equal l1 l2
-
- let rec is_identity = function
- | [] -> true
- | true :: l -> is_identity l
- | false :: _ -> false
-
- let normalize f = if is_identity f then None else Some f
-
- let filter_list f l = match f with
- | None -> l
- | Some f -> CList.filter_with f l
-
- let filter_array f v = match f with
- | None -> v
- | Some f -> CArray.filter_with f v
-
- let rec extend n l =
- if n = 0 then l
- else extend (pred n) (true :: l)
-
- let extend n = function
- | None -> None
- | Some f -> Some (extend n f)
-
- let compose f1 f2 = match f1 with
- | None -> f2
- | Some f1 ->
- match f2 with
- | None -> None
- | Some f2 -> normalize (CList.filter_with f1 f2)
-
- let apply_subfilter_array filter subfilter =
- (** In both cases we statically know that the argument will contain at
- least one [false] *)
- match filter with
- | None -> Some (Array.to_list subfilter)
- | Some f ->
- let len = Array.length subfilter in
- let fold b (i, ans) =
- if b then
- let () = assert (0 <= i) in
- (pred i, Array.unsafe_get subfilter i :: ans)
- else
- (i, false :: ans)
- in
- Some (snd (List.fold_right fold f (pred len, [])))
-
- let apply_subfilter filter subfilter =
- apply_subfilter_array filter (Array.of_list subfilter)
-
- let restrict_upon f len p =
- let newfilter = Array.init len p in
- if Array.for_all (fun id -> id) newfilter then None
- else
- Some (apply_subfilter_array f newfilter)
-
- let map_along f flt l =
- let ans = match flt with
- | None -> List.map (fun x -> f true x) l
- | Some flt -> List.map2 f flt l
- in
- normalize ans
-
- let make l = normalize l
-
- let repr f = f
-
-end
-
-(* The kinds of existential variables are now defined in [Evar_kinds] *)
-
-(* The type of mappings for existential variables *)
-
-module Dummy = struct end
-module Store = Store.Make(Dummy)
-
-type evar = Term.existential_key
-
-let string_of_existential evk = "?X" ^ string_of_int (Evar.repr evk)
-
-type evar_body =
- | Evar_empty
- | Evar_defined of constr
-
-type evar_info = {
- evar_concl : constr;
- evar_hyps : named_context_val;
- evar_body : evar_body;
- evar_filter : Filter.t;
- evar_source : Evar_kinds.t Loc.located;
- evar_candidates : constr list option; (* if not None, list of allowed instances *)
- evar_extra : Store.t }
-
-let make_evar hyps ccl = {
- evar_concl = ccl;
- evar_hyps = hyps;
- evar_body = Evar_empty;
- evar_filter = Filter.identity;
- evar_source = (Loc.ghost,Evar_kinds.InternalHole);
- evar_candidates = None;
- evar_extra = Store.empty
-}
-
-let instance_mismatch () =
- anomaly (Pp.str "Signature and its instance do not match")
-
-let evar_concl evi = evi.evar_concl
-
-let evar_filter evi = evi.evar_filter
-
-let evar_body evi = evi.evar_body
-
-let evar_context evi = named_context_of_val evi.evar_hyps
-
-let evar_filtered_context evi =
- Filter.filter_list (evar_filter evi) (evar_context evi)
-
-let evar_hyps evi = evi.evar_hyps
-
-let evar_filtered_hyps evi = match Filter.repr (evar_filter evi) with
-| None -> evar_hyps evi
-| Some filter ->
- let rec make_hyps filter ctxt = match filter, ctxt with
- | [], [] -> empty_named_context_val
- | false :: filter, _ :: ctxt -> make_hyps filter ctxt
- | true :: filter, decl :: ctxt ->
- let hyps = make_hyps filter ctxt in
- push_named_context_val decl hyps
- | _ -> instance_mismatch ()
- in
- make_hyps filter (evar_context evi)
-
-let evar_env evi = Global.env_of_context evi.evar_hyps
-
-let evar_filtered_env evi = match Filter.repr (evar_filter evi) with
-| None -> evar_env evi
-| Some filter ->
- let rec make_env filter ctxt = match filter, ctxt with
- | [], [] -> reset_context (Global.env ())
- | false :: filter, _ :: ctxt -> make_env filter ctxt
- | true :: filter, decl :: ctxt ->
- let env = make_env filter ctxt in
- push_named decl env
- | _ -> instance_mismatch ()
- in
- make_env filter (evar_context evi)
-
-let map_evar_body f = function
- | Evar_empty -> Evar_empty
- | Evar_defined d -> Evar_defined (f d)
-
-let map_evar_info f evi =
- {evi with
- evar_body = map_evar_body f evi.evar_body;
- evar_hyps = map_named_val f evi.evar_hyps;
- evar_concl = f evi.evar_concl;
- evar_candidates = Option.map (List.map f) evi.evar_candidates }
-
-let evar_ident_info evi =
- match evi.evar_source with
- | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id
- | _,Evar_kinds.VarInstance id -> id
- | _,Evar_kinds.GoalEvar -> Id.of_string "Goal"
- | _ ->
- let env = reset_with_named_context evi.evar_hyps (Global.env()) in
- Namegen.id_of_name_using_hdchar env evi.evar_concl Anonymous
-
-(* This exception is raised by *.existential_value *)
-exception NotInstantiatedEvar
-
-(* Note: let-in contributes to the instance *)
-
-let evar_instance_array test_id info args =
- let len = Array.length args in
- let rec instrec filter ctxt i = match filter, ctxt with
- | [], [] ->
- if Int.equal i len then []
- else instance_mismatch ()
- | false :: filter, _ :: ctxt ->
- instrec filter ctxt i
- | true :: filter, (id,_,_ as d) :: ctxt ->
- if i < len then
- let c = Array.unsafe_get args i in
- if test_id d c then instrec filter ctxt (succ i)
- else (id, c) :: instrec filter ctxt (succ i)
- else instance_mismatch ()
- | _ -> instance_mismatch ()
- in
- match Filter.repr (evar_filter info) with
- | None ->
- let map i (id,_,_ as d) =
- if (i < len) then
- let c = Array.unsafe_get args i in
- if test_id d c then None else Some (id,c)
- else instance_mismatch ()
- in
- List.map_filter_i map (evar_context info)
- | Some filter ->
- instrec filter (evar_context info) 0
-
-let make_evar_instance_array info args =
- evar_instance_array (fun (id,_,_) -> isVarId id) info args
-
-let instantiate_evar_array info c args =
- let inst = make_evar_instance_array info args in
- match inst with
- | [] -> c
- | _ -> replace_vars inst c
-
-module StringOrd = struct type t = string let compare = String.compare end
-module UNameMap = struct
-
- include Map.Make(StringOrd)
-
- let union s t =
- if s == t then s
- else
- merge (fun k l r ->
- match l, r with
- | Some _, _ -> l
- | _, _ -> r) s t
-end
-
-(* 2nd part used to check consistency on the fly. *)
-type evar_universe_context =
- { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t;
- uctx_local : Univ.universe_context_set; (** The local context of variables *)
- uctx_univ_variables : Universes.universe_opt_subst;
- (** The local universes that are unification variables *)
- uctx_univ_algebraic : Univ.universe_set;
- (** The subset of unification variables that can be instantiated with
- algebraic universes as they appear in inferred types only. *)
- uctx_universes : Univ.universes; (** The current graph extended with the local constraints *)
- uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *)
- }
-
-let empty_evar_universe_context =
- { uctx_names = UNameMap.empty, Univ.LMap.empty;
- uctx_local = Univ.ContextSet.empty;
- uctx_univ_variables = Univ.LMap.empty;
- uctx_univ_algebraic = Univ.LSet.empty;
- uctx_universes = Univ.initial_universes;
- uctx_initial_universes = Univ.initial_universes }
-
-let evar_universe_context_from e =
- let u = universes e in
- {empty_evar_universe_context with
- uctx_universes = u; uctx_initial_universes = u}
-
-let is_empty_evar_universe_context ctx =
- Univ.ContextSet.is_empty ctx.uctx_local &&
- Univ.LMap.is_empty ctx.uctx_univ_variables
-
-let union_evar_universe_context ctx ctx' =
- if ctx == ctx' then ctx
- else if is_empty_evar_universe_context ctx' then ctx
- else
- let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in
- let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in
- let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local)
- (Univ.ContextSet.levels ctx.uctx_local) in
- let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in
- let declarenew g =
- Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g
- in
- let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in
- { uctx_names = (names, names_rev);
- uctx_local = local;
- uctx_univ_variables =
- Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables;
- uctx_univ_algebraic =
- Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic;
- uctx_initial_universes = declarenew ctx.uctx_initial_universes;
- uctx_universes =
- if local == ctx.uctx_local then ctx.uctx_universes
- else
- let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in
- Univ.merge_constraints cstrsr (declarenew ctx.uctx_universes) }
-
-(* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *)
-(* let union_evar_universe_context = *)
-(* Profile.profile2 union_evar_universe_context_key union_evar_universe_context;; *)
-
-type 'a in_evar_universe_context = 'a * evar_universe_context
-
-let evar_universe_context_set diff ctx =
- let initctx = ctx.uctx_local in
- let cstrs =
- Univ.LSet.fold
- (fun l cstrs ->
- try
- match Univ.LMap.find l ctx.uctx_univ_variables with
- | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs
- | None -> cstrs
- with Not_found | Option.IsNone -> cstrs)
- (Univ.Instance.levels (Univ.UContext.instance diff)) Univ.Constraint.empty
- in
- Univ.ContextSet.add_constraints cstrs initctx
-
-let evar_universe_context_constraints ctx = snd ctx.uctx_local
-let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_local
-
-let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx }
-let evar_universe_context_subst ctx = ctx.uctx_univ_variables
-
-let add_uctx_names s l (names, names_rev) =
- (UNameMap.add s l names, Univ.LMap.add l s names_rev)
-
-let evar_universe_context_of_binders b =
- let ctx = empty_evar_universe_context in
- let names =
- List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc)
- ctx.uctx_names b
- in { ctx with uctx_names = names }
-
-let instantiate_variable l b v =
- v := Univ.LMap.add l (Some b) !v
-
-exception UniversesDiffer
-
-let process_universe_constraints univs vars alg cstrs =
- let vars = ref vars in
- let normalize = Universes.normalize_universe_opt_subst vars in
- let rec unify_universes fo l d r local =
- let l = normalize l and r = normalize r in
- if Univ.Universe.equal l r then local
- else
- let varinfo x =
- match Univ.Universe.level x with
- | None -> Inl x
- | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg)
- in
- if d == Universes.ULe then
- if Univ.check_leq univs l r then
- (** Keep Prop/Set <= var around if var might be instantiated by prop or set
- later. *)
- if Univ.Universe.is_level l then
- match Univ.Universe.level r with
- | Some r ->
- Univ.Constraint.add (Option.get (Univ.Universe.level l),Univ.Le,r) local
- | _ -> local
- else local
- else
- match Univ.Universe.level r with
- | None -> error ("Algebraic universe on the right")
- | Some rl ->
- if Univ.Level.is_small rl then
- let levels = Univ.Universe.levels l in
- Univ.LSet.fold (fun l local ->
- if Univ.Level.is_small l || Univ.LMap.mem l !vars then
- unify_universes fo (Univ.Universe.make l) Universes.UEq r local
- else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None)))
- levels local
- else
- Univ.enforce_leq l r local
- else if d == Universes.ULub then
- match varinfo l, varinfo r with
- | (Inr (l, true, _), Inr (r, _, _))
- | (Inr (r, _, _), Inr (l, true, _)) ->
- instantiate_variable l (Univ.Universe.make r) vars;
- Univ.enforce_eq_level l r local
- | Inr (_, _, _), Inr (_, _, _) ->
- unify_universes true l Universes.UEq r local
- | _, _ -> assert false
- else (* d = Universes.UEq *)
- match varinfo l, varinfo r with
- | Inr (l', lloc, _), Inr (r', rloc, _) ->
- let () =
- if lloc then
- instantiate_variable l' r vars
- else if rloc then
- instantiate_variable r' l vars
- else if not (Univ.check_eq univs l r) then
- (* Two rigid/global levels, none of them being local,
- one of them being Prop/Set, disallow *)
- if Univ.Level.is_small l' || Univ.Level.is_small r' then
- raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None))
- else
- if fo then
- raise UniversesDiffer
- in
- Univ.enforce_eq_level l' r' local
- | Inr (l, loc, alg), Inl r
- | Inl r, Inr (l, loc, alg) ->
- let inst = Univ.univ_level_rem l r r in
- if alg then (instantiate_variable l inst vars; local)
- else
- let lu = Univ.Universe.make l in
- if Univ.univ_level_mem l r then
- Univ.enforce_leq inst lu local
- else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None))
- | _, _ (* One of the two is algebraic or global *) ->
- if Univ.check_eq univs l r then local
- else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None))
- in
- let local =
- Universes.Constraints.fold (fun (l,d,r) local -> unify_universes false l d r local)
- cstrs Univ.Constraint.empty
- in
- !vars, local
-
-let add_constraints_context ctx cstrs =
- let univs, local = ctx.uctx_local in
- let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc ->
- let l = Univ.Universe.make l and r = Univ.Universe.make r in
- let cstr' =
- if d == Univ.Lt then (Univ.Universe.super l, Universes.ULe, r)
- else (l, (if d == Univ.Le then Universes.ULe else Universes.UEq), r)
- in Universes.Constraints.add cstr' acc)
- cstrs Universes.Constraints.empty
- in
- let vars, local' =
- process_universe_constraints ctx.uctx_universes
- ctx.uctx_univ_variables ctx.uctx_univ_algebraic
- cstrs'
- in
- { ctx with uctx_local = (univs, Univ.Constraint.union local local');
- uctx_univ_variables = vars;
- uctx_universes = Univ.merge_constraints local' ctx.uctx_universes }
-
-(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *)
-(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *)
-
-let add_universe_constraints_context ctx cstrs =
- let univs, local = ctx.uctx_local in
- let vars, local' =
- process_universe_constraints ctx.uctx_universes
- ctx.uctx_univ_variables ctx.uctx_univ_algebraic
- cstrs
- in
- { ctx with uctx_local = (univs, Univ.Constraint.union local local');
- uctx_univ_variables = vars;
- uctx_universes = Univ.merge_constraints local' ctx.uctx_universes }
-
-(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *)
-(* let add_universe_constraints_context = *)
-(* Profile.profile2 addunivconstrkey add_universe_constraints_context;; *)
-(*******************************************************************)
-(* Metamaps *)
-
-(*******************************************************************)
-(* Constraints for existential variables *)
-(*******************************************************************)
-
-type 'a freelisted = {
- rebus : 'a;
- freemetas : Int.Set.t }
-
-(* Collects all metavars appearing in a constr *)
-let metavars_of c =
- let rec collrec acc c =
- match kind_of_term c with
- | Meta mv -> Int.Set.add mv acc
- | _ -> fold_constr collrec acc c
- in
- collrec Int.Set.empty c
-
-let mk_freelisted c =
- { rebus = c; freemetas = metavars_of c }
-
-let map_fl f cfl = { cfl with rebus=f cfl.rebus }
-
-(* Status of an instance found by unification wrt to the meta it solves:
- - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X)
- - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X)
- - a term that can be eta-expanded n times while still being a solution
- (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
-*)
-
-type instance_constraint = IsSuperType | IsSubType | Conv
-
-let eq_instance_constraint c1 c2 = c1 == c2
-
-(* Status of the unification of the type of an instance against the type of
- the meta it instantiates:
- - CoerceToType means that the unification of types has not been done
- and that a coercion can still be inserted: the meta should not be
- substituted freely (this happens for instance given via the
- "with" binding clause).
- - TypeProcessed means that the information obtainable from the
- unification of types has been extracted.
- - TypeNotProcessed means that the unification of types has not been
- done but it is known that no coercion may be inserted: the meta
- can be substituted freely.
-*)
-
-type instance_typing_status =
- CoerceToType | TypeNotProcessed | TypeProcessed
-
-(* Status of an instance together with the status of its type unification *)
-
-type instance_status = instance_constraint * instance_typing_status
-
-(* Clausal environments *)
-
-type clbinding =
- | Cltyp of Name.t * constr freelisted
- | Clval of Name.t * (constr freelisted * instance_status) * constr freelisted
-
-let map_clb f = function
- | Cltyp (na,cfl) -> Cltyp (na,map_fl f cfl)
- | Clval (na,(cfl1,pb),cfl2) -> Clval (na,(map_fl f cfl1,pb),map_fl f cfl2)
-
-(* name of defined is erased (but it is pretty-printed) *)
-let clb_name = function
- Cltyp(na,_) -> (na,false)
- | Clval (na,_,_) -> (na,true)
-
-(***********************)
-
-module Metaset = Int.Set
-
-module Metamap = Int.Map
-
-let metamap_to_list m =
- Metamap.fold (fun n v l -> (n,v)::l) m []
-
-(*************************)
-(* Unification state *)
-
-type conv_pb = Reduction.conv_pb
-type evar_constraint = conv_pb * Environ.env * constr * constr
-
-module EvMap = Evar.Map
-
-type evar_map = {
- (** Existential variables *)
- defn_evars : evar_info EvMap.t;
- undf_evars : evar_info EvMap.t;
- evar_names : Id.t EvMap.t * existential_key Idmap.t;
- (** Universes *)
- universes : evar_universe_context;
- (** Conversion problems *)
- conv_pbs : evar_constraint list;
- last_mods : Evar.Set.t;
- (** Metas *)
- metas : clbinding Metamap.t;
- (** Interactive proofs *)
- effects : Safe_typing.private_constants;
- future_goals : Evar.t list; (** list of newly created evars, to be
- eventually turned into goals if not solved.*)
- principal_future_goal : Evar.t option; (** if [Some e], [e] must be
- contained
- [future_goals]. The evar
- [e] will inherit
- properties (now: the
- name) of the evar which
- will be instantiated with
- a term containing [e]. *)
- extras : Store.t;
-}
-
-(*** Lifting primitive from Evar.Map. ***)
-
-let add_name_newly_undefined naming evk evi (evtoid,idtoev) =
- let id = match naming with
- | Misctypes.IntroAnonymous ->
- let id = evar_ident_info evi in
- Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev)
- | Misctypes.IntroIdentifier id ->
- let id' =
- Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
- if not (Names.Id.equal id id') then
- user_err_loc
- (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id);
- id'
- | Misctypes.IntroFresh id ->
- Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
- (EvMap.add evk id evtoid, Idmap.add id evk idtoev)
-
-let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) =
- if EvMap.mem evk evtoid then
- evar_names
- else
- add_name_newly_undefined naming evk evi evar_names
-
-let remove_name_defined evk (evtoid,idtoev) =
- let id = EvMap.find evk evtoid in
- (EvMap.remove evk evtoid, Idmap.remove id idtoev)
-
-let remove_name_possibly_already_defined evk evar_names =
- try remove_name_defined evk evar_names
- with Not_found -> evar_names
-
-let rename evk id evd =
- let (evtoid,idtoev) = evd.evar_names in
- let id' = EvMap.find evk evtoid in
- if Idmap.mem id idtoev then anomaly (str "Evar name already in use");
- { evd with evar_names =
- (EvMap.add evk id evtoid (* overwrite old name *),
- Idmap.add id evk (Idmap.remove id' idtoev)) }
-
-let reassign_name_defined evk evk' (evtoid,idtoev) =
- let id = EvMap.find evk evtoid in
- (EvMap.add evk' id (EvMap.remove evk evtoid),
- Idmap.add id evk' (Idmap.remove id idtoev))
-
-let add d e i = match i.evar_body with
-| Evar_empty ->
- let evar_names = add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in
- { d with undf_evars = EvMap.add e i d.undf_evars; evar_names }
-| Evar_defined _ ->
- let evar_names = remove_name_possibly_already_defined e d.evar_names in
- { d with defn_evars = EvMap.add e i d.defn_evars; evar_names }
-
-let remove d e =
- let undf_evars = EvMap.remove e d.undf_evars in
- let defn_evars = EvMap.remove e d.defn_evars in
- let principal_future_goal = match d.principal_future_goal with
- | None -> None
- | Some e' -> if Evar.equal e e' then None else d.principal_future_goal
- in
- let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in
- { d with undf_evars; defn_evars; principal_future_goal; future_goals }
-
-let find d e =
- try EvMap.find e d.undf_evars
- with Not_found -> EvMap.find e d.defn_evars
-
-let find_undefined d e = EvMap.find e d.undf_evars
-
-let mem d e = EvMap.mem e d.undf_evars || EvMap.mem e d.defn_evars
-
-(* spiwack: this function loses information from the original evar_map
- it might be an idea not to export it. *)
-let to_list d =
- (* Workaround for change in Map.fold behavior in ocaml 3.08.4 *)
- let l = ref [] in
- EvMap.iter (fun evk x -> l := (evk,x)::!l) d.defn_evars;
- EvMap.iter (fun evk x -> l := (evk,x)::!l) d.undf_evars;
- !l
-
-let undefined_map d = d.undf_evars
-
-let drop_all_defined d = { d with defn_evars = EvMap.empty }
-
-(* spiwack: not clear what folding over an evar_map, for now we shall
- simply fold over the inner evar_map. *)
-let fold f d a =
- EvMap.fold f d.defn_evars (EvMap.fold f d.undf_evars a)
-
-let fold_undefined f d a = EvMap.fold f d.undf_evars a
-
-let raw_map f d =
- let f evk info =
- let ans = f evk info in
- let () = match info.evar_body, ans.evar_body with
- | Evar_defined _, Evar_empty
- | Evar_empty, Evar_defined _ ->
- anomaly (str "Unrespectful mapping function.")
- | _ -> ()
- in
- ans
- in
- let defn_evars = EvMap.smartmapi f d.defn_evars in
- let undf_evars = EvMap.smartmapi f d.undf_evars in
- { d with defn_evars; undf_evars; }
-
-let raw_map_undefined f d =
- let f evk info =
- let ans = f evk info in
- let () = match ans.evar_body with
- | Evar_defined _ ->
- anomaly (str "Unrespectful mapping function.")
- | _ -> ()
- in
- ans
- in
- { d with undf_evars = EvMap.smartmapi f d.undf_evars; }
-
-let is_evar = mem
-
-let is_defined d e = EvMap.mem e d.defn_evars
-
-let is_undefined d e = EvMap.mem e d.undf_evars
-
-let existential_value d (n, args) =
- let info = find d n in
- match evar_body info with
- | Evar_defined c ->
- instantiate_evar_array info c args
- | Evar_empty ->
- raise NotInstantiatedEvar
-
-let existential_opt_value d ev =
- try Some (existential_value d ev)
- with NotInstantiatedEvar -> None
-
-let existential_type d (n, args) =
- let info =
- try find d n
- with Not_found ->
- anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared") in
- instantiate_evar_array info info.evar_concl args
-
-let add_constraints d c =
- { d with universes = add_constraints_context d.universes c }
-
-let add_universe_constraints d c =
- { d with universes = add_universe_constraints_context d.universes c }
-
-(*** /Lifting... ***)
-
-(* evar_map are considered empty disregarding histories *)
-let is_empty d =
- EvMap.is_empty d.defn_evars &&
- EvMap.is_empty d.undf_evars &&
- List.is_empty d.conv_pbs &&
- Metamap.is_empty d.metas
-
-let cmap f evd =
- { evd with
- metas = Metamap.map (map_clb f) evd.metas;
- defn_evars = EvMap.map (map_evar_info f) evd.defn_evars;
- undf_evars = EvMap.map (map_evar_info f) evd.undf_evars
- }
-
-(* spiwack: deprecated *)
-let create_evar_defs sigma = { sigma with
- conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty }
-(* spiwack: tentatively deprecated *)
-let create_goal_evar_defs sigma = { sigma with
- (* conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } *)
- metas=Metamap.empty }
-
-let empty = {
- defn_evars = EvMap.empty;
- undf_evars = EvMap.empty;
- universes = empty_evar_universe_context;
- conv_pbs = [];
- last_mods = Evar.Set.empty;
- metas = Metamap.empty;
- effects = Safe_typing.empty_private_constants;
- evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *)
- future_goals = [];
- principal_future_goal = None;
- extras = Store.empty;
-}
-
-let from_env e =
- { empty with universes = evar_universe_context_from e }
-
-let from_ctx ctx = { empty with universes = ctx }
-
-let has_undefined evd = not (EvMap.is_empty evd.undf_evars)
-
-let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d =
- let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in
- let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in
- let universes =
- if not with_univs then evd.universes
- else union_evar_universe_context evd.universes d.universes
- in
- { evd with
- metas = d.metas;
- last_mods; conv_pbs; universes }
-
-let merge_universe_context evd uctx' =
- { evd with universes = union_evar_universe_context evd.universes uctx' }
-
-let set_universe_context evd uctx' =
- { evd with universes = uctx' }
-
-let add_conv_pb ?(tail=false) pb d =
- if tail then {d with conv_pbs = d.conv_pbs @ [pb]}
- else {d with conv_pbs = pb::d.conv_pbs}
-
-let evar_source evk d = (find d evk).evar_source
-
-let evar_ident evk evd =
- try EvMap.find evk (fst evd.evar_names)
- with Not_found ->
- (* Unnamed (non-dependent) evar *)
- add_suffix (Id.of_string "X") (string_of_int (Evar.repr evk))
-
-let evar_key id evd =
- Idmap.find id (snd evd.evar_names)
-
-let define_aux def undef evk body =
- let oldinfo =
- try EvMap.find evk undef
- with Not_found ->
- if EvMap.mem evk def then
- anomaly ~label:"Evd.define" (Pp.str "cannot define an evar twice")
- else
- anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar")
- in
- let () = assert (oldinfo.evar_body == Evar_empty) in
- let newinfo = { oldinfo with evar_body = Evar_defined body } in
- EvMap.add evk newinfo def, EvMap.remove evk undef
-
-(* define the existential of section path sp as the constr body *)
-let define evk body evd =
- let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in
- let last_mods = match evd.conv_pbs with
- | [] -> evd.last_mods
- | _ -> Evar.Set.add evk evd.last_mods
- in
- let evar_names = remove_name_defined evk evd.evar_names in
- { evd with defn_evars; undf_evars; last_mods; evar_names }
-
-let evar_declare hyps evk ty ?(src=(Loc.ghost,Evar_kinds.InternalHole))
- ?(filter=Filter.identity) ?candidates ?(store=Store.empty)
- ?(naming=Misctypes.IntroAnonymous) evd =
- let () = match Filter.repr filter with
- | None -> ()
- | Some filter ->
- assert (Int.equal (List.length filter) (List.length (named_context_of_val hyps)))
- in
- let evar_info = {
- evar_hyps = hyps;
- evar_concl = ty;
- evar_body = Evar_empty;
- evar_filter = filter;
- evar_source = src;
- evar_candidates = candidates;
- evar_extra = store; }
- in
- let evar_names = add_name_newly_undefined naming evk evar_info evd.evar_names in
- { evd with undf_evars = EvMap.add evk evar_info evd.undf_evars; evar_names }
-
-let restrict evk evk' filter ?candidates evd =
- let evar_info = EvMap.find evk evd.undf_evars in
- let evar_info' =
- { evar_info with evar_filter = filter;
- evar_candidates = candidates;
- evar_extra = Store.empty } in
- let evar_names = reassign_name_defined evk evk' evd.evar_names in
- let ctxt = Filter.filter_list filter (evar_context evar_info) in
- let id_inst = Array.map_of_list (fun (id,_,_) -> mkVar id) ctxt in
- let body = mkEvar(evk',id_inst) in
- let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in
- { evd with undf_evars = EvMap.add evk' evar_info' undf_evars;
- defn_evars; evar_names }
-
-let downcast evk ccl evd =
- let evar_info = EvMap.find evk evd.undf_evars in
- let evar_info' = { evar_info with evar_concl = ccl } in
- { evd with undf_evars = EvMap.add evk evar_info' evd.undf_evars }
-
-(* extracts conversion problems that satisfy predicate p *)
-(* Note: conv_pbs not satisying p are stored back in reverse order *)
-let extract_conv_pbs evd p =
- let (pbs,pbs1) =
- List.fold_left
- (fun (pbs,pbs1) pb ->
- if p pb then
- (pb::pbs,pbs1)
- else
- (pbs,pb::pbs1))
- ([],[])
- evd.conv_pbs
- in
- {evd with conv_pbs = pbs1; last_mods = Evar.Set.empty},
- pbs
-
-let extract_changed_conv_pbs evd p =
- extract_conv_pbs evd (fun pb -> p evd.last_mods pb)
-
-let extract_all_conv_pbs evd =
- extract_conv_pbs evd (fun _ -> true)
-
-let loc_of_conv_pb evd (pbty,env,t1,t2) =
- match kind_of_term (fst (decompose_app t1)) with
- | Evar (evk1,_) -> fst (evar_source evk1 evd)
- | _ ->
- match kind_of_term (fst (decompose_app t2)) with
- | Evar (evk2,_) -> fst (evar_source evk2 evd)
- | _ -> Loc.ghost
-
-(** The following functions return the set of evars immediately
- contained in the object *)
-
-(* excluding defined evars *)
-
-let evar_list c =
- let rec evrec acc c =
- match kind_of_term c with
- | Evar (evk, _ as ev) -> ev :: acc
- | _ -> fold_constr evrec acc c in
- evrec [] c
-
-let evars_of_term c =
- let rec evrec acc c =
- match kind_of_term c with
- | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l)
- | _ -> fold_constr evrec acc c
- in
- evrec Evar.Set.empty c
-
-let evars_of_named_context nc =
- List.fold_right (fun (_, b, t) s ->
- Option.fold_left (fun s t ->
- Evar.Set.union s (evars_of_term t))
- (Evar.Set.union s (evars_of_term t)) b)
- nc Evar.Set.empty
-
-let evars_of_filtered_evar_info evi =
- Evar.Set.union (evars_of_term evi.evar_concl)
- (Evar.Set.union
- (match evi.evar_body with
- | Evar_empty -> Evar.Set.empty
- | Evar_defined b -> evars_of_term b)
- (evars_of_named_context (evar_filtered_context evi)))
-
-(**********************************************************)
-(* Sort variables *)
-
-type rigid =
- | UnivRigid
- | UnivFlexible of bool (** Is substitution by an algebraic ok? *)
-
-let univ_rigid = UnivRigid
-let univ_flexible = UnivFlexible false
-let univ_flexible_alg = UnivFlexible true
-
-let evar_universe_context d = d.universes
-
-let universe_context_set d = d.universes.uctx_local
-
-let pr_uctx_level uctx =
- let map, map_rev = uctx.uctx_names in
- fun l ->
- try str(Univ.LMap.find l map_rev)
- with Not_found ->
- Universes.pr_with_global_universes l
-
-let universe_context ?names evd =
- match names with
- | None -> [], Univ.ContextSet.to_context evd.universes.uctx_local
- | Some pl ->
- let levels = Univ.ContextSet.levels evd.universes.uctx_local in
- let newinst, map, left =
- List.fold_right
- (fun (loc,id) (newinst, map, acc) ->
- let l =
- try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names)
- with Not_found ->
- user_err_loc (loc, "universe_context",
- str"Universe " ++ pr_id id ++ str" is not bound anymore.")
- in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc))
- pl ([], [], levels)
- in
- if not (Univ.LSet.is_empty left) then
- let n = Univ.LSet.cardinal left in
- errorlabstrm "universe_context"
- (str(CString.plural n "Universe") ++ spc () ++
- Univ.LSet.pr (pr_uctx_level evd.universes) left ++
- spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")
- else
- let inst = Univ.Instance.of_array (Array.of_list newinst) in
- let ctx = Univ.UContext.make (inst,
- Univ.ContextSet.constraints evd.universes.uctx_local)
- in map, ctx
-
-let restrict_universe_context evd vars =
- let uctx = evd.universes in
- let uctx' = Universes.restrict_universe_context uctx.uctx_local vars in
- { evd with universes = { uctx with uctx_local = uctx' } }
-
-let universe_subst evd =
- evd.universes.uctx_univ_variables
-
-let merge_uctx sideff rigid uctx ctx' =
- let open Univ in
- let levels = ContextSet.levels ctx' in
- let uctx = if sideff then uctx else
- match rigid with
- | UnivRigid -> uctx
- | UnivFlexible b ->
- let fold u accu =
- if LMap.mem u accu then accu
- else LMap.add u None accu
- in
- let uvars' = LSet.fold fold levels uctx.uctx_univ_variables in
- if b then
- { uctx with uctx_univ_variables = uvars';
- uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels }
- else { uctx with uctx_univ_variables = uvars' }
- in
- let uctx_local =
- if sideff then uctx.uctx_local
- else ContextSet.append ctx' uctx.uctx_local
- in
- let declare g =
- LSet.fold (fun u g ->
- try Univ.add_universe u false g
- with Univ.AlreadyDeclared when sideff -> g)
- levels g
- in
- let initial = declare uctx.uctx_initial_universes in
- let univs = declare uctx.uctx_universes in
- let uctx_universes = merge_constraints (ContextSet.constraints ctx') univs in
- { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial }
-
-let merge_context_set ?(sideff=false) rigid evd ctx' =
- {evd with universes = merge_uctx sideff rigid evd.universes ctx'}
-
-let merge_uctx_subst uctx s =
- { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s }
-
-let merge_universe_subst evd subst =
- {evd with universes = merge_uctx_subst evd.universes subst }
-
-let with_context_set rigid d (a, ctx) =
- (merge_context_set rigid d ctx, a)
-
-let emit_universe_side_effects eff u =
- let uctxs = Safe_typing.universes_of_private eff in
- List.fold_left (merge_uctx true univ_rigid) u uctxs
-
-let uctx_new_univ_variable rigid name predicative
- ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) =
- let u = Universes.new_univ_level (Global.current_dirpath ()) in
- let ctx' = Univ.ContextSet.add_universe u ctx in
- let uctx', pred =
- match rigid with
- | UnivRigid -> uctx, true
- | UnivFlexible b ->
- let uvars' = Univ.LMap.add u None uvars in
- if b then {uctx with uctx_univ_variables = uvars';
- uctx_univ_algebraic = Univ.LSet.add u avars}, false
- else {uctx with uctx_univ_variables = uvars'}, false
- in
- let names =
- match name with
- | Some n -> add_uctx_names n u uctx.uctx_names
- | None -> uctx.uctx_names
- in
- let initial =
- Univ.add_universe u false uctx.uctx_initial_universes
- in
- let uctx' =
- {uctx' with uctx_names = names; uctx_local = ctx';
- uctx_universes = Univ.add_universe u false uctx.uctx_universes;
- uctx_initial_universes = initial}
- in uctx', u
-
-let new_univ_level_variable ?name ?(predicative=true) rigid evd =
- let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in
- ({evd with universes = uctx'}, u)
-
-let new_univ_variable ?name ?(predicative=true) rigid evd =
- let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in
- ({evd with universes = uctx'}, Univ.Universe.make u)
-
-let new_sort_variable ?name ?(predicative=true) rigid d =
- let (d', u) = new_univ_variable rigid ?name ~predicative d in
- (d', Type u)
-
-let add_global_univ d u =
- let uctx = d.universes in
- let initial =
- Univ.add_universe u true uctx.uctx_initial_universes
- in
- let univs =
- Univ.add_universe u true uctx.uctx_universes
- in
- { d with universes = { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local;
- uctx_initial_universes = initial;
- uctx_universes = univs } }
-
-let make_flexible_variable evd b u =
- let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in
- let uvars' = Univ.LMap.add u None uvars in
- let avars' =
- if b then
- let uu = Univ.Universe.make u in
- let substu_not_alg u' v =
- Option.cata (fun vu -> Univ.Universe.equal uu vu && not (Univ.LSet.mem u' avars)) false v
- in
- if not (Univ.LMap.exists substu_not_alg uvars)
- then Univ.LSet.add u avars else avars
- else avars
- in
- {evd with universes = {ctx with uctx_univ_variables = uvars';
- uctx_univ_algebraic = avars'}}
-
-let make_evar_universe_context e l =
- let uctx = evar_universe_context_from e in
- match l with
- | None -> uctx
- | Some us ->
- List.fold_left
- (fun uctx (loc,id) ->
- fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) true uctx))
- uctx us
-
-(****************************************)
-(* Operations on constants *)
-(****************************************)
-
-let fresh_sort_in_family ?(rigid=univ_flexible) env evd s =
- with_context_set rigid evd (Universes.fresh_sort_in_family env s)
-
-let fresh_constant_instance env evd c =
- with_context_set univ_flexible evd (Universes.fresh_constant_instance env c)
-
-let fresh_inductive_instance env evd i =
- with_context_set univ_flexible evd (Universes.fresh_inductive_instance env i)
-
-let fresh_constructor_instance env evd c =
- with_context_set univ_flexible evd (Universes.fresh_constructor_instance env c)
-
-let fresh_global ?(rigid=univ_flexible) ?names env evd gr =
- with_context_set rigid evd (Universes.fresh_global_instance ?names env gr)
-
-let whd_sort_variable evd t = t
-
-let is_sort_variable evd s =
- match s with
- | Type u ->
- (match Univ.universe_level u with
- | Some l as x ->
- let uctx = evd.universes in
- if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x
- else None
- | None -> None)
- | _ -> None
-
-let is_flexible_level evd l =
- let uctx = evd.universes in
- Univ.LMap.mem l uctx.uctx_univ_variables
-
-let is_eq_sort s1 s2 =
- if Sorts.equal s1 s2 then None
- else
- let u1 = univ_of_sort s1
- and u2 = univ_of_sort s2 in
- if Univ.Universe.equal u1 u2 then None
- else Some (u1, u2)
-
-let normalize_universe evd =
- let vars = ref evd.universes.uctx_univ_variables in
- let normalize = Universes.normalize_universe_opt_subst vars in
- normalize
-
-let normalize_universe_instance evd l =
- let vars = ref evd.universes.uctx_univ_variables in
- let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in
- Univ.Instance.subst_fn normalize l
-
-let normalize_sort evars s =
- match s with
- | Prop _ -> s
- | Type u ->
- let u' = normalize_universe evars u in
- if u' == u then s else Type u'
-
-(* FIXME inefficient *)
-let set_eq_sort env d s1 s2 =
- let s1 = normalize_sort d s1 and s2 = normalize_sort d s2 in
- match is_eq_sort s1 s2 with
- | None -> d
- | Some (u1, u2) ->
- if not (type_in_type env) then
- add_universe_constraints d
- (Universes.Constraints.singleton (u1,Universes.UEq,u2))
- else
- d
-
-let has_lub evd u1 u2 =
- (* let normalize = Universes.normalize_universe_opt_subst (ref univs.uctx_univ_variables) in *)
- (* (\* let dref, norm = memo_normalize_universe d in *\) *)
- (* let u1 = normalize u1 and u2 = normalize u2 in *)
- if Univ.Universe.equal u1 u2 then evd
- else add_universe_constraints evd
- (Universes.Constraints.singleton (u1,Universes.ULub,u2))
-
-let set_eq_level d u1 u2 =
- add_constraints d (Univ.enforce_eq_level u1 u2 Univ.Constraint.empty)
-
-let set_leq_level d u1 u2 =
- add_constraints d (Univ.enforce_leq_level u1 u2 Univ.Constraint.empty)
-
-let set_eq_instances ?(flex=false) d u1 u2 =
- add_universe_constraints d
- (Universes.enforce_eq_instances_univs flex u1 u2 Universes.Constraints.empty)
-
-let set_leq_sort env evd s1 s2 =
- let s1 = normalize_sort evd s1
- and s2 = normalize_sort evd s2 in
- match is_eq_sort s1 s2 with
- | None -> evd
- | Some (u1, u2) ->
- (* if Univ.is_type0_univ u2 then *)
- (* if Univ.is_small_univ u1 then evd *)
- (* else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, [])) *)
- (* else if Univ.is_type0m_univ u2 then *)
- (* raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, [])) *)
- (* else *)
- if not (type_in_type env) then
- add_universe_constraints evd (Universes.Constraints.singleton (u1,Universes.ULe,u2))
- else evd
-
-let check_eq evd s s' =
- Univ.check_eq evd.universes.uctx_universes s s'
-
-let check_leq evd s s' =
- Univ.check_leq evd.universes.uctx_universes s s'
-
-let subst_univs_context_with_def def usubst (ctx, cst) =
- (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst)
-
-let normalize_evar_universe_context_variables uctx =
- let normalized_variables, undef, def, subst =
- Universes.normalize_univ_variables uctx.uctx_univ_variables
- in
- let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in
- let ctx_local', univs = Universes.refresh_constraints uctx.uctx_initial_universes ctx_local in
- subst, { uctx with uctx_local = ctx_local';
- uctx_univ_variables = normalized_variables;
- uctx_universes = univs }
-
-(* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *)
-(* let normalize_evar_universe_context_variables = *)
-(* Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *)
-
-let abstract_undefined_variables uctx =
- let vars' =
- Univ.LMap.fold (fun u v acc ->
- if v == None then Univ.LSet.remove u acc
- else acc)
- uctx.uctx_univ_variables uctx.uctx_univ_algebraic
- in { uctx with uctx_local = Univ.ContextSet.empty;
- uctx_univ_algebraic = vars' }
-
-let fix_undefined_variables ({ universes = uctx } as evm) =
- let algs', vars' =
- Univ.LMap.fold (fun u v (algs, vars as acc) ->
- if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars)
- else acc)
- uctx.uctx_univ_variables
- (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables)
- in
- {evm with universes =
- { uctx with uctx_univ_variables = vars';
- uctx_univ_algebraic = algs' } }
-
-
-let refresh_undefined_univ_variables uctx =
- let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in
- let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc)
- uctx.uctx_univ_algebraic Univ.LSet.empty
- in
- let vars =
- Univ.LMap.fold
- (fun u v acc ->
- Univ.LMap.add (Univ.subst_univs_level_level subst u)
- (Option.map (Univ.subst_univs_level_universe subst) v) acc)
- uctx.uctx_univ_variables Univ.LMap.empty
- in
- let declare g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g)
- (Univ.ContextSet.levels ctx') g in
- let initial = declare uctx.uctx_initial_universes in
- let univs = declare Univ.initial_universes in
- let uctx' = {uctx_names = uctx.uctx_names;
- uctx_local = ctx';
- uctx_univ_variables = vars; uctx_univ_algebraic = alg;
- uctx_universes = univs;
- uctx_initial_universes = initial } in
- uctx', subst
-
-let refresh_undefined_universes evd =
- let uctx', subst = refresh_undefined_univ_variables evd.universes in
- let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in
- evd', subst
-
-let normalize_evar_universe_context uctx =
- let rec fixpoint uctx =
- let ((vars',algs'), us') =
- Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables
- uctx.uctx_univ_algebraic
- in
- if Univ.ContextSet.equal us' uctx.uctx_local then uctx
- else
- let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in
- let uctx' =
- { uctx_names = uctx.uctx_names;
- uctx_local = us';
- uctx_univ_variables = vars';
- uctx_univ_algebraic = algs';
- uctx_universes = universes;
- uctx_initial_universes = uctx.uctx_initial_universes }
- in fixpoint uctx'
- in fixpoint uctx
-
-let nf_univ_variables evd =
- let subst, uctx' = normalize_evar_universe_context_variables evd.universes in
- let evd' = {evd with universes = uctx'} in
- evd', subst
-
-let nf_constraints evd =
- let subst, uctx' = normalize_evar_universe_context_variables evd.universes in
- let uctx' = normalize_evar_universe_context uctx' in
- {evd with universes = uctx'}
-
-let nf_constraints =
- if Flags.profile then
- let nfconstrkey = Profile.declare_profile "nf_constraints" in
- Profile.profile1 nfconstrkey nf_constraints
- else nf_constraints
-
-let universe_of_name evd s =
- UNameMap.find s (fst evd.universes.uctx_names)
-
-let add_universe_name evd s l =
- let names' = add_uctx_names s l evd.universes.uctx_names in
- {evd with universes = {evd.universes with uctx_names = names'}}
-
-let universes evd = evd.universes.uctx_universes
-
-let update_sigma_env evd env =
- let univs = Environ.universes env in
- let eunivs =
- { evd.universes with uctx_initial_universes = univs;
- uctx_universes = univs }
- in
- let eunivs = merge_uctx true univ_rigid eunivs eunivs.uctx_local in
- { evd with universes = eunivs }
-
-(* Conversion w.r.t. an evar map and its local universes. *)
-
-let test_conversion_gen env evd pb t u =
- match pb with
- | Reduction.CONV ->
- Reduction.trans_conv_universes
- full_transparent_state ~evars:(existential_opt_value evd) env
- evd.universes.uctx_universes t u
- | Reduction.CUMUL -> Reduction.trans_conv_leq_universes
- full_transparent_state ~evars:(existential_opt_value evd) env
- evd.universes.uctx_universes t u
-
-let test_conversion env d pb t u =
- try test_conversion_gen env d pb t u; true
- with _ -> false
-
-let eq_constr_univs evd t u =
- let b, c = Universes.eq_constr_univs_infer evd.universes.uctx_universes t u in
- if b then
- try let evd' = add_universe_constraints evd c in evd', b
- with Univ.UniverseInconsistency _ | UniversesDiffer -> evd, false
- else evd, b
-
-let e_eq_constr_univs evdref t u =
- let evd, b = eq_constr_univs !evdref t u in
- evdref := evd; b
-
-(**********************************************************)
-(* Side effects *)
-
-let emit_side_effects eff evd =
- { evd with effects = Safe_typing.concat_private eff evd.effects;
- universes = emit_universe_side_effects eff evd.universes }
-
-let drop_side_effects evd =
- { evd with effects = Safe_typing.empty_private_constants; }
-
-let eval_side_effects evd = evd.effects
-
-(* Future goals *)
-let declare_future_goal evk evd =
- { evd with future_goals = evk::evd.future_goals }
-
-let declare_principal_goal evk evd =
- match evd.principal_future_goal with
- | None -> { evd with
- future_goals = evk::evd.future_goals;
- principal_future_goal=Some evk; }
- | Some _ -> Errors.error "Only one main subgoal per instantiation."
-
-let future_goals evd = evd.future_goals
-
-let principal_future_goal evd = evd.principal_future_goal
-
-let reset_future_goals evd =
- { evd with future_goals = [] ; principal_future_goal=None }
-
-let restore_future_goals evd gls pgl =
- { evd with future_goals = gls ; principal_future_goal = pgl }
-
-(**********************************************************)
-(* Accessing metas *)
-
-(** We use this function to overcome OCaml compiler limitations and to prevent
- the use of costly in-place modifications. *)
-let set_metas evd metas = {
- defn_evars = evd.defn_evars;
- undf_evars = evd.undf_evars;
- universes = evd.universes;
- conv_pbs = evd.conv_pbs;
- last_mods = evd.last_mods;
- metas;
- effects = evd.effects;
- evar_names = evd.evar_names;
- future_goals = evd.future_goals;
- principal_future_goal = evd.principal_future_goal;
- extras = evd.extras;
-}
-
-let meta_list evd = metamap_to_list evd.metas
-
-let undefined_metas evd =
- let filter = function
- | (n,Clval(_,_,typ)) -> None
- | (n,Cltyp (_,typ)) -> Some n
- in
- let m = List.map_filter filter (meta_list evd) in
- List.sort Int.compare m
-
-let map_metas_fvalue f evd =
- let map = function
- | Clval(id,(c,s),typ) -> Clval(id,(mk_freelisted (f c.rebus),s),typ)
- | x -> x
- in
- set_metas evd (Metamap.smartmap map evd.metas)
-
-let meta_opt_fvalue evd mv =
- match Metamap.find mv evd.metas with
- | Clval(_,b,_) -> Some b
- | Cltyp _ -> None
-
-let meta_defined evd mv =
- match Metamap.find mv evd.metas with
- | Clval _ -> true
- | Cltyp _ -> false
-
-let try_meta_fvalue evd mv =
- match Metamap.find mv evd.metas with
- | Clval(_,b,_) -> b
- | Cltyp _ -> raise Not_found
-
-let meta_fvalue evd mv =
- try try_meta_fvalue evd mv
- with Not_found -> anomaly ~label:"meta_fvalue" (Pp.str "meta has no value")
-
-let meta_value evd mv =
- (fst (try_meta_fvalue evd mv)).rebus
-
-let meta_ftype evd mv =
- match Metamap.find mv evd.metas with
- | Cltyp (_,b) -> b
- | Clval(_,_,b) -> b
-
-let meta_type evd mv = (meta_ftype evd mv).rebus
-
-let meta_declare mv v ?(name=Anonymous) evd =
- let metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas in
- set_metas evd metas
-
-let meta_assign mv (v, pb) evd =
- let modify _ = function
- | Cltyp (na, ty) -> Clval (na, (mk_freelisted v, pb), ty)
- | _ -> anomaly ~label:"meta_assign" (Pp.str "already defined")
- in
- let metas = Metamap.modify mv modify evd.metas in
- set_metas evd metas
-
-let meta_reassign mv (v, pb) evd =
- let modify _ = function
- | Clval(na, _, ty) -> Clval (na, (mk_freelisted v, pb), ty)
- | _ -> anomaly ~label:"meta_reassign" (Pp.str "not yet defined")
- in
- let metas = Metamap.modify mv modify evd.metas in
- set_metas evd metas
-
-(* If the meta is defined then forget its name *)
-let meta_name evd mv =
- try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous
-
-let explain_no_such_bound_variable evd id =
- let mvl =
- List.rev (Metamap.fold (fun n clb l ->
- let na = fst (clb_name clb) in
- if na != Anonymous then out_name na :: l else l)
- evd.metas []) in
- errorlabstrm "Evd.meta_with_name"
- (str"No such bound variable " ++ pr_id id ++
- (if mvl == [] then str " (no bound variables at all in the expression)."
- else
- (str" (possible name" ++
- str (if List.length mvl == 1 then " is: " else "s are: ") ++
- pr_enum pr_id mvl ++ str").")))
-
-let meta_with_name evd id =
- let na = Name id in
- let (mvl,mvnodef) =
- Metamap.fold
- (fun n clb (l1,l2 as l) ->
- let (na',def) = clb_name clb in
- if Name.equal na na' then if def then (n::l1,l2) else (n::l1,n::l2)
- else l)
- evd.metas ([],[]) in
- match mvnodef, mvl with
- | _,[] ->
- explain_no_such_bound_variable evd id
- | ([n],_|_,[n]) ->
- n
- | _ ->
- errorlabstrm "Evd.meta_with_name"
- (str "Binder name \"" ++ pr_id id ++
- strbrk "\" occurs more than once in clause.")
-
-let clear_metas evd = {evd with metas = Metamap.empty}
-
-let meta_merge ?(with_univs = true) evd1 evd2 =
- let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in
- let universes =
- if with_univs then union_evar_universe_context evd2.universes evd1.universes
- else evd2.universes
- in
- {evd2 with universes; metas; }
-
-type metabinding = metavariable * constr * instance_status
-
-let retract_coercible_metas evd =
- let mc = ref [] in
- let map n v = match v with
- | Clval (na, (b, (Conv, CoerceToType as s)), typ) ->
- let () = mc := (n, b.rebus, s) :: !mc in
- Cltyp (na, typ)
- | v -> v
- in
- let metas = Metamap.smartmapi map evd.metas in
- !mc, set_metas evd metas
-
-let subst_defined_metas_evars (bl,el) c =
- let rec substrec c = match kind_of_term c with
- | Meta i ->
- let select (j,_,_) = Int.equal i j in
- substrec (pi2 (List.find select bl))
- | Evar (evk,args) ->
- let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in
- (try substrec (pi3 (List.find select el))
- with Not_found -> map_constr substrec c)
- | _ -> map_constr substrec c
- in try Some (substrec c) with Not_found -> None
-
-let evar_source_of_meta mv evd =
- match meta_name evd mv with
- | Anonymous -> (Loc.ghost,Evar_kinds.GoalEvar)
- | Name id -> (Loc.ghost,Evar_kinds.VarInstance id)
-
-let dependent_evar_ident ev evd =
- let evi = find evd ev in
- match evi.evar_source with
- | (_,Evar_kinds.VarInstance id) -> id
- | _ -> anomaly (str "Not an evar resulting of a dependent binding")
-
-(**********************************************************)
-(* Extra data *)
-
-let get_extra_data evd = evd.extras
-let set_extra_data extras evd = { evd with extras }
-
-(*******************************************************************)
-
-type pending = (* before: *) evar_map * (* after: *) evar_map
-
-type pending_constr = pending * constr
-
-type open_constr = evar_map * constr
-
-(*******************************************************************)
-(* The type constructor ['a sigma] adds an evar map to an object of
- type ['a] *)
-type 'a sigma = {
- it : 'a ;
- sigma : evar_map
-}
-
-let sig_it x = x.it
-let sig_sig x = x.sigma
-let on_sig s f =
- let sigma', v = f s.sigma in
- { s with sigma = sigma' }, v
-
-(*******************************************************************)
-(* The state monad with state an evar map. *)
-
-module MonadR =
- Monad.Make (struct
-
- type +'a t = evar_map -> evar_map * 'a
-
- let return a = fun s -> (s,a)
-
- let (>>=) x f = fun s ->
- let (s',a) = x s in
- f a s'
-
- let (>>) x y = fun s ->
- let (s',()) = x s in
- y s'
-
- let map f x = fun s ->
- on_snd f (x s)
-
- end)
-
-module Monad =
- Monad.Make (struct
-
- type +'a t = evar_map -> 'a * evar_map
-
- let return a = fun s -> (a,s)
-
- let (>>=) x f = fun s ->
- let (a,s') = x s in
- f a s'
-
- let (>>) x y = fun s ->
- let ((),s') = x s in
- y s'
-
- let map f x = fun s ->
- on_fst f (x s)
-
- end)
-
-(**********************************************************)
-(* Failure explanation *)
-
-type unsolvability_explanation = SeveralInstancesFound of int
-
-(**********************************************************)
-(* Pretty-printing *)
-
-let pr_existential_key sigma evk = str "?" ++ pr_id (evar_ident evk sigma)
-
-let pr_instance_status (sc,typ) =
- begin match sc with
- | IsSubType -> str " [or a subtype of it]"
- | IsSuperType -> str " [or a supertype of it]"
- | Conv -> mt ()
- end ++
- begin match typ with
- | CoerceToType -> str " [up to coercion]"
- | TypeNotProcessed -> mt ()
- | TypeProcessed -> str " [type is checked]"
- end
-
-let pr_meta_map mmap =
- let pr_name = function
- Name id -> str"[" ++ pr_id id ++ str"]"
- | _ -> mt() in
- let pr_meta_binding = function
- | (mv,Cltyp (na,b)) ->
- hov 0
- (pr_meta mv ++ pr_name na ++ str " : " ++
- print_constr b.rebus ++ fnl ())
- | (mv,Clval(na,(b,s),t)) ->
- hov 0
- (pr_meta mv ++ pr_name na ++ str " := " ++
- print_constr b.rebus ++
- str " : " ++ print_constr t.rebus ++
- spc () ++ pr_instance_status s ++ fnl ())
- in
- prlist pr_meta_binding (metamap_to_list mmap)
-
-let pr_decl ((id,b,_),ok) =
- match b with
- | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}")
- | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++
- print_constr c ++ str (if ok then ")" else "}")
-
-let rec pr_evar_source = function
- | Evar_kinds.QuestionMark _ -> str "underscore"
- | Evar_kinds.CasesType false -> str "pattern-matching return predicate"
- | Evar_kinds.CasesType true ->
- str "subterm of pattern-matching return predicate"
- | Evar_kinds.BinderType (Name id) -> str "type of " ++ Nameops.pr_id id
- | Evar_kinds.BinderType Anonymous -> str "type of anonymous binder"
- | Evar_kinds.ImplicitArg (c,(n,ido),b) ->
- let id = Option.get ido in
- str "parameter " ++ pr_id id ++ spc () ++ str "of" ++
- spc () ++ print_constr (printable_constr_of_global c)
- | Evar_kinds.InternalHole -> str "internal placeholder"
- | Evar_kinds.TomatchTypeParameter (ind,n) ->
- pr_nth n ++ str " argument of type " ++ print_constr (mkInd ind)
- | Evar_kinds.GoalEvar -> str "goal evar"
- | Evar_kinds.ImpossibleCase -> str "type of impossible pattern-matching clause"
- | Evar_kinds.MatchingVar _ -> str "matching variable"
- | Evar_kinds.VarInstance id -> str "instance of " ++ pr_id id
- | Evar_kinds.SubEvar evk ->
- str "subterm of " ++ str (string_of_existential evk)
-
-let pr_evar_info evi =
- let phyps =
- try
- let decls = match Filter.repr (evar_filter evi) with
- | None -> List.map (fun c -> (c, true)) (evar_context evi)
- | Some filter -> List.combine (evar_context evi) filter
- in
- prlist_with_sep spc pr_decl (List.rev decls)
- with Invalid_argument _ -> str "Ill-formed filtered context" in
- let pty = print_constr evi.evar_concl in
- let pb =
- match evi.evar_body with
- | Evar_empty -> mt ()
- | Evar_defined c -> spc() ++ str"=> " ++ print_constr c
- in
- let candidates =
- match evi.evar_body, evi.evar_candidates with
- | Evar_empty, Some l ->
- spc () ++ str "{" ++
- prlist_with_sep (fun () -> str "|") print_constr l ++ str "}"
- | _ ->
- mt ()
- in
- let src = str "(" ++ pr_evar_source (snd evi.evar_source) ++ str ")" in
- hov 2
- (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]" ++
- candidates ++ spc() ++ src)
-
-let compute_evar_dependency_graph (sigma : evar_map) =
- (* Compute the map binding ev to the evars whose body depends on ev *)
- let fold evk evi acc =
- let fold_ev evk' acc =
- let tab =
- try EvMap.find evk' acc
- with Not_found -> Evar.Set.empty
- in
- EvMap.add evk' (Evar.Set.add evk tab) acc
- in
- match evar_body evi with
- | Evar_empty -> assert false
- | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term c) acc
- in
- EvMap.fold fold sigma.defn_evars EvMap.empty
-
-let evar_dependency_closure n sigma =
- (** Create the DAG of depth [n] representing the recursive dependencies of
- undefined evars. *)
- let graph = compute_evar_dependency_graph sigma in
- let rec aux n curr accu =
- if Int.equal n 0 then Evar.Set.union curr accu
- else
- let fold evk accu =
- try
- let deps = EvMap.find evk graph in
- Evar.Set.union deps accu
- with Not_found -> accu
- in
- (** Consider only the newly added evars *)
- let ncurr = Evar.Set.fold fold curr Evar.Set.empty in
- (** Merge the others *)
- let accu = Evar.Set.union curr accu in
- aux (n - 1) ncurr accu
- in
- let undef = EvMap.domain (undefined_map sigma) in
- aux n undef Evar.Set.empty
-
-let evar_dependency_closure n sigma =
- let deps = evar_dependency_closure n sigma in
- let map = EvMap.bind (fun ev -> find sigma ev) deps in
- EvMap.bindings map
-
-let has_no_evar sigma =
- EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars
-
-let pr_evd_level evd = pr_uctx_level evd.universes
-
-let pr_evar_universe_context ctx =
- let prl = pr_uctx_level ctx in
- if is_empty_evar_universe_context ctx then mt ()
- else
- (str"UNIVERSES:"++brk(0,1)++
- h 0 (Univ.pr_universe_context_set prl ctx.uctx_local) ++ fnl () ++
- str"ALGEBRAIC UNIVERSES:"++brk(0,1)++
- h 0 (Univ.LSet.pr prl ctx.uctx_univ_algebraic) ++ fnl() ++
- str"UNDEFINED UNIVERSES:"++brk(0,1)++
- h 0 (Universes.pr_universe_opt_subst ctx.uctx_univ_variables) ++ fnl())
-
-let print_env_short env =
- let pr_body n = function
- | None -> pr_name n
- | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in
- let pr_named_decl (n, b, _) = pr_body (Name n) b in
- let pr_rel_decl (n, b, _) = pr_body n b in
- let nc = List.rev (named_context env) in
- let rc = List.rev (rel_context env) in
- str "[" ++ pr_sequence pr_named_decl nc ++ str "]" ++ spc () ++
- str "[" ++ pr_sequence pr_rel_decl rc ++ str "]"
-
-let pr_evar_constraints pbs =
- let pr_evconstr (pbty, env, t1, t2) =
- print_env_short env ++ spc () ++ str "|-" ++ spc () ++
- print_constr_env env t1 ++ spc () ++
- str (match pbty with
- | Reduction.CONV -> "=="
- | Reduction.CUMUL -> "<=") ++
- spc () ++ print_constr_env env t2
- in
- prlist_with_sep fnl pr_evconstr pbs
-
-let pr_evar_map_gen with_univs pr_evars sigma =
- let { universes = uvs } = sigma in
- let evs = if has_no_evar sigma then mt () else pr_evars sigma ++ fnl ()
- and svs = if with_univs then pr_evar_universe_context uvs else mt ()
- and cstrs =
- if List.is_empty sigma.conv_pbs then mt ()
- else
- str "CONSTRAINTS:" ++ brk (0, 1) ++
- pr_evar_constraints sigma.conv_pbs ++ fnl ()
- and metas =
- if Metamap.is_empty sigma.metas then mt ()
- else
- str "METAS:" ++ brk (0, 1) ++ pr_meta_map sigma.metas
- in
- evs ++ svs ++ cstrs ++ metas
-
-let pr_evar_list sigma l =
- let pr (ev, evi) =
- h 0 (str (string_of_existential ev) ++
- str "==" ++ pr_evar_info evi ++
- (if evi.evar_body == Evar_empty
- then str " {" ++ pr_id (evar_ident ev sigma) ++ str "}"
- else mt ()))
- in
- h 0 (prlist_with_sep fnl pr l)
-
-let pr_evar_by_depth depth sigma = match depth with
-| None ->
- (* Print all evars *)
- str"EVARS:"++brk(0,1)++pr_evar_list sigma (to_list sigma)++fnl()
-| Some n ->
- (* Print all evars *)
- str"UNDEFINED EVARS:"++
- (if Int.equal n 0 then mt() else str" (+level "++int n++str" closure):")++
- brk(0,1)++
- pr_evar_list sigma (evar_dependency_closure n sigma)++fnl()
-
-let pr_evar_by_filter filter sigma =
- let defined = Evar.Map.filter filter sigma.defn_evars in
- let undefined = Evar.Map.filter filter sigma.undf_evars in
- let prdef =
- if Evar.Map.is_empty defined then mt ()
- else str "DEFINED EVARS:" ++ brk (0, 1) ++
- pr_evar_list sigma (Evar.Map.bindings defined)
- in
- let prundef =
- if Evar.Map.is_empty undefined then mt ()
- else str "UNDEFINED EVARS:" ++ brk (0, 1) ++
- pr_evar_list sigma (Evar.Map.bindings undefined)
- in
- prdef ++ prundef
-
-let pr_evar_map ?(with_univs=true) depth sigma =
- pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_depth depth sigma) sigma
-
-let pr_evar_map_filter ?(with_univs=true) filter sigma =
- pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_filter filter sigma) sigma
-
-let pr_metaset metas =
- str "[" ++ pr_sequence pr_meta (Metaset.elements metas) ++ str "]"
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
deleted file mode 100644
index 0b4f1853..00000000
--- a/pretyping/evd.mli
+++ /dev/null
@@ -1,621 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Util
-open Loc
-open Names
-open Term
-open Context
-open Environ
-
-(** {5 Existential variables and unification states}
-
- A unification state (of type [evar_map]) is primarily a finite mapping
- from existential variables to records containing the type of the evar
- ([evar_concl]), the context under which it was introduced ([evar_hyps])
- and its definition ([evar_body]). [evar_extra] is used to add any other
- kind of information.
-
- It also contains conversion constraints, debugging information and
- information about meta variables. *)
-
-(** {6 Evars} *)
-
-type evar = existential_key
-(** Existential variables. TODO: Should be made opaque one day. *)
-
-val string_of_existential : evar -> string
-
-(** {6 Evar filters} *)
-
-module Filter :
-sig
- type t
- (** Evar filters, seen as bitmasks. *)
-
- val equal : t -> t -> bool
- (** Equality over filters *)
-
- val identity : t
- (** The identity filter. *)
-
- val filter_list : t -> 'a list -> 'a list
- (** Filter a list. Sizes must coincide. *)
-
- val filter_array : t -> 'a array -> 'a array
- (** Filter an array. Sizes must coincide. *)
-
- val extend : int -> t -> t
- (** [extend n f] extends [f] on the left with [n]-th times [true]. *)
-
- val compose : t -> t -> t
- (** Horizontal composition : [compose f1 f2] only keeps parts of [f2] where
- [f1] is set. In particular, [f1] and [f2] must have the same length. *)
-
- val apply_subfilter : t -> bool list -> t
- (** [apply_subfilter f1 f2] applies filter [f2] where [f1] is [true]. In
- particular, the length of [f2] is the number of times [f1] is [true] *)
-
- val restrict_upon : t -> int -> (int -> bool) -> t option
- (** Ad-hoc primitive. *)
-
- val map_along : (bool -> 'a -> bool) -> t -> 'a list -> t
- (** Apply the function on the filter and the list. Sizes must coincide. *)
-
- val make : bool list -> t
- (** Create out of a list *)
-
- val repr : t -> bool list option
- (** Observe as a bool list. *)
-
-end
-
-(** {6 Evar infos} *)
-
-type evar_body =
- | Evar_empty
- | Evar_defined of constr
-
-
-module Store : Store.S
-(** Datatype used to store additional information in evar maps. *)
-
-type evar_info = {
- evar_concl : constr;
- (** Type of the evar. *)
- evar_hyps : named_context_val;
- (** Context of the evar. *)
- evar_body : evar_body;
- (** Optional content of the evar. *)
- evar_filter : Filter.t;
- (** Boolean mask over {!evar_hyps}. Should have the same length.
- TODO: document me more. *)
- evar_source : Evar_kinds.t located;
- (** Information about the evar. *)
- evar_candidates : constr list option;
- (** TODO: document this *)
- evar_extra : Store.t
- (** Extra store, used for clever hacks. *)
-}
-
-val make_evar : named_context_val -> types -> evar_info
-val evar_concl : evar_info -> constr
-val evar_context : evar_info -> named_context
-val evar_filtered_context : evar_info -> named_context
-val evar_hyps : evar_info -> named_context_val
-val evar_filtered_hyps : evar_info -> named_context_val
-val evar_body : evar_info -> evar_body
-val evar_filter : evar_info -> Filter.t
-val evar_env : evar_info -> env
-val evar_filtered_env : evar_info -> env
-
-val map_evar_body : (constr -> constr) -> evar_body -> evar_body
-val map_evar_info : (constr -> constr) -> evar_info -> evar_info
-
-(** {6 Unification state} **)
-
-type evar_universe_context
-(** The universe context associated to an evar map *)
-
-type evar_map
-(** Type of unification state. Essentially a bunch of state-passing data needed
- to handle incremental term construction. *)
-
-val empty : evar_map
-(** The empty evar map. *)
-
-val from_env : env -> evar_map
-(** The empty evar map with given universe context, taking its initial
- universes from env. *)
-
-val from_ctx : evar_universe_context -> evar_map
-(** The empty evar map with given universe context *)
-
-val is_empty : evar_map -> bool
-(** Whether an evarmap is empty. *)
-
-val has_undefined : evar_map -> bool
-(** [has_undefined sigma] is [true] if and only if
- there are uninstantiated evars in [sigma]. *)
-
-val add : evar_map -> evar -> evar_info -> evar_map
-(** [add sigma ev info] adds [ev] with evar info [info] in sigma.
- Precondition: ev must not preexist in [sigma]. *)
-
-val find : evar_map -> evar -> evar_info
-(** Recover the data associated to an evar. *)
-
-val find_undefined : evar_map -> evar -> evar_info
-(** Same as {!find} but restricted to undefined evars. For efficiency
- reasons. *)
-
-val remove : evar_map -> evar -> evar_map
-(** Remove an evar from an evar map. Use with caution. *)
-
-val mem : evar_map -> evar -> bool
-(** Whether an evar is present in an evarmap. *)
-
-val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
-(** Apply a function to all evars and their associated info in an evarmap. *)
-
-val fold_undefined : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
-(** Same as {!fold}, but restricted to undefined evars. For efficiency
- reasons. *)
-
-val raw_map : (evar -> evar_info -> evar_info) -> evar_map -> evar_map
-(** Apply the given function to all evars in the map. Beware: this function
- expects the argument function to preserve the kind of [evar_body], i.e. it
- must send [Evar_empty] to [Evar_empty] and [Evar_defined c] to some
- [Evar_defined c']. *)
-
-val raw_map_undefined : (evar -> evar_info -> evar_info) -> evar_map -> evar_map
-(** Same as {!raw_map}, but restricted to undefined evars. For efficiency
- reasons. *)
-
-val define : evar -> constr -> evar_map -> evar_map
-(** Set the body of an evar to the given constr. It is expected that:
- {ul
- {- The evar is already present in the evarmap.}
- {- The evar is not defined in the evarmap yet.}
- {- All the evars present in the constr should be present in the evar map.}
- } *)
-
-val cmap : (constr -> constr) -> evar_map -> evar_map
-(** Map the function on all terms in the evar map. *)
-
-val is_evar : evar_map -> evar -> bool
-(** Alias for {!mem}. *)
-
-val is_defined : evar_map -> evar -> bool
-(** Whether an evar is defined in an evarmap. *)
-
-val is_undefined : evar_map -> evar -> bool
-(** Whether an evar is not defined in an evarmap. *)
-
-val add_constraints : evar_map -> Univ.constraints -> evar_map
-(** Add universe constraints in an evar map. *)
-
-val undefined_map : evar_map -> evar_info Evar.Map.t
-(** Access the undefined evar mapping directly. *)
-
-val drop_all_defined : evar_map -> evar_map
-
-(** {6 Instantiating partial terms} *)
-
-exception NotInstantiatedEvar
-
-val existential_value : evar_map -> existential -> constr
-(** [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
- no body and [Not_found] if it does not exist in [sigma] *)
-
-val existential_type : evar_map -> existential -> types
-
-val existential_opt_value : evar_map -> existential -> constr option
-(** Same as {!existential_value} but returns an option instead of raising an
- exception. *)
-
-val evar_instance_array : (named_declaration -> 'a -> bool) -> evar_info ->
- 'a array -> (Id.t * 'a) list
-
-val instantiate_evar_array : evar_info -> constr -> constr array -> constr
-
-val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool ->
- evar_map -> evar_map -> evar_map
-(** spiwack: this function seems to somewhat break the abstraction. *)
-
-(** {6 Misc} *)
-
-val evar_declare :
- named_context_val -> evar -> types -> ?src:Loc.t * Evar_kinds.t ->
- ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr -> evar_map -> evar_map
-(** Convenience function. Just a wrapper around {!add}. *)
-
-val restrict : evar -> evar -> Filter.t -> ?candidates:constr list ->
- evar_map -> evar_map
-(** Restrict an undefined evar into a new evar by filtering context and
- possibly limiting the instances to a set of candidates *)
-
-val downcast : evar -> types -> evar_map -> evar_map
-(** Change the type of an undefined evar to a new type assumed to be a
- subtype of its current type; subtyping must be ensured by caller *)
-
-val evar_source : existential_key -> evar_map -> Evar_kinds.t located
-(** Convenience function. Wrapper around {!find} to recover the source of an
- evar in a given evar map. *)
-
-val evar_ident : existential_key -> evar_map -> Id.t
-
-val rename : existential_key -> Id.t -> evar_map -> evar_map
-
-val evar_key : Id.t -> evar_map -> existential_key
-
-val evar_source_of_meta : metavariable -> evar_map -> Evar_kinds.t located
-
-val dependent_evar_ident : existential_key -> evar_map -> Id.t
-
-(** {5 Side-effects} *)
-
-val emit_side_effects : Safe_typing.private_constants -> evar_map -> evar_map
-(** Push a side-effect into the evar map. *)
-
-val eval_side_effects : evar_map -> Safe_typing.private_constants
-(** Return the effects contained in the evar map. *)
-
-val drop_side_effects : evar_map -> evar_map
-(** This should not be used. For hacking purposes. *)
-
-(** {5 Future goals} *)
-
-val declare_future_goal : Evar.t -> evar_map -> evar_map
-(** Adds an existential variable to the list of future goals. For
- internal uses only. *)
-
-val declare_principal_goal : Evar.t -> evar_map -> evar_map
-(** Adds an existential variable to the list of future goals and make
- it principal. Only one existential variable can be made principal, an
- error is raised otherwise. For internal uses only. *)
-
-val future_goals : evar_map -> Evar.t list
-(** Retrieves the list of future goals. Used by the [refine] primitive
- of the tactic engine. *)
-
-val principal_future_goal : evar_map -> Evar.t option
-(** Retrieves the name of the principal existential variable if there
- is one. Used by the [refine] primitive of the tactic engine. *)
-
-val reset_future_goals : evar_map -> evar_map
-(** Clears the list of future goals (as well as the principal future
- goal). Used by the [refine] primitive of the tactic engine. *)
-
-val restore_future_goals : evar_map -> Evar.t list -> Evar.t option -> evar_map
-(** Sets the future goals (including the principal future goal) to a
- previous value. Intended to be used after a local list of future
- goals has been consumed. Used by the [refine] primitive of the
- tactic engine. *)
-
-(** {5 Sort variables}
-
- Evar maps also keep track of the universe constraints defined at a given
- point. This section defines the relevant manipulation functions. *)
-
-val whd_sort_variable : evar_map -> constr -> constr
-
-exception UniversesDiffer
-
-val add_universe_constraints : evar_map -> Universes.universe_constraints -> evar_map
-(** Add the given universe unification constraints to the evar map.
- @raises UniversesDiffer in case a first-order unification fails.
- @raises UniverseInconsistency
-*)
-
-(** {5 Extra data}
-
- Evar maps can contain arbitrary data, allowing to use an extensible state.
- As evar maps are theoretically used in a strict state-passing style, such
- additional data should be passed along transparently. Some old and bug-prone
- code tends to drop them nonetheless, so you should keep cautious.
-
-*)
-
-val get_extra_data : evar_map -> Store.t
-val set_extra_data : Store.t -> evar_map -> evar_map
-
-(** {5 Enriching with evar maps} *)
-
-type 'a sigma = {
- it : 'a ;
- (** The base object. *)
- sigma : evar_map
- (** The added unification state. *)
-}
-(** The type constructor ['a sigma] adds an evar map to an object of type
- ['a]. *)
-
-val sig_it : 'a sigma -> 'a
-val sig_sig : 'a sigma -> evar_map
-val on_sig : 'a sigma -> (evar_map -> evar_map * 'b) -> 'a sigma * 'b
-
-(** {5 The state monad with state an evar map} *)
-
-module MonadR : Monad.S with type +'a t = evar_map -> evar_map * 'a
-module Monad : Monad.S with type +'a t = evar_map -> 'a * evar_map
-
-
-(** {5 Meta machinery}
-
- These functions are almost deprecated. They were used before the
- introduction of the full-fledged evar calculus. In an ideal world, they
- should be removed. Alas, some parts of the code still use them. Do not use
- in newly-written code. *)
-
-module Metaset : Set.S with type elt = metavariable
-module Metamap : Map.ExtS with type key = metavariable and module Set := Metaset
-
-type 'a freelisted = {
- rebus : 'a;
- freemetas : Metaset.t }
-
-val metavars_of : constr -> Metaset.t
-val mk_freelisted : constr -> constr freelisted
-val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted
-
-(** Status of an instance found by unification wrt to the meta it solves:
- - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X)
- - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X)
- - a term that can be eta-expanded n times while still being a solution
- (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
-*)
-
-type instance_constraint = IsSuperType | IsSubType | Conv
-
-val eq_instance_constraint :
- instance_constraint -> instance_constraint -> bool
-
-(** Status of the unification of the type of an instance against the type of
- the meta it instantiates:
- - CoerceToType means that the unification of types has not been done
- and that a coercion can still be inserted: the meta should not be
- substituted freely (this happens for instance given via the
- "with" binding clause).
- - TypeProcessed means that the information obtainable from the
- unification of types has been extracted.
- - TypeNotProcessed means that the unification of types has not been
- done but it is known that no coercion may be inserted: the meta
- can be substituted freely.
-*)
-
-type instance_typing_status =
- CoerceToType | TypeNotProcessed | TypeProcessed
-
-(** Status of an instance together with the status of its type unification *)
-
-type instance_status = instance_constraint * instance_typing_status
-
-(** Clausal environments *)
-
-type clbinding =
- | Cltyp of Name.t * constr freelisted
- | Clval of Name.t * (constr freelisted * instance_status) * constr freelisted
-
-(** Unification constraints *)
-type conv_pb = Reduction.conv_pb
-type evar_constraint = conv_pb * env * constr * constr
-val add_conv_pb : ?tail:bool -> evar_constraint -> evar_map -> evar_map
-
-val extract_changed_conv_pbs : evar_map ->
- (Evar.Set.t -> evar_constraint -> bool) ->
- evar_map * evar_constraint list
-val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list
-val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t
-
-(** The following functions return the set of evars immediately
- contained in the object; need the term to be evar-normal otherwise
- defined evars are returned too. *)
-
-val evar_list : constr -> existential list
- (** excluding evars in instances of evars and collected with
- redundancies from right to left (used by tactic "instantiate") *)
-
-val evars_of_term : constr -> Evar.Set.t
- (** including evars in instances of evars *)
-
-val evars_of_named_context : named_context -> Evar.Set.t
-
-val evars_of_filtered_evar_info : evar_info -> Evar.Set.t
-
-(** Metas *)
-val meta_list : evar_map -> (metavariable * clbinding) list
-val meta_defined : evar_map -> metavariable -> bool
-
-val meta_value : evar_map -> metavariable -> constr
-(** [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if
- meta has no value *)
-
-val meta_fvalue : evar_map -> metavariable -> constr freelisted * instance_status
-val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_status) option
-val meta_type : evar_map -> metavariable -> types
-val meta_ftype : evar_map -> metavariable -> types freelisted
-val meta_name : evar_map -> metavariable -> Name.t
-val meta_with_name : evar_map -> Id.t -> metavariable
-val meta_declare :
- metavariable -> types -> ?name:Name.t -> evar_map -> evar_map
-val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map
-val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map
-
-val clear_metas : evar_map -> evar_map
-
-(** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)
-val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map
-
-val undefined_metas : evar_map -> metavariable list
-val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map
-
-type metabinding = metavariable * constr * instance_status
-
-val retract_coercible_metas : evar_map -> metabinding list * evar_map
-val subst_defined_metas_evars : metabinding list * ('a * existential * constr) list -> constr -> constr option
-
-(** {5 FIXME: Nothing to do here} *)
-
-(*********************************************************
- Sort/universe variables *)
-
-(** Rigid or flexible universe variables *)
-
-type rigid =
- | UnivRigid
- | UnivFlexible of bool (** Is substitution by an algebraic ok? *)
-
-val univ_rigid : rigid
-val univ_flexible : rigid
-val univ_flexible_alg : rigid
-
-type 'a in_evar_universe_context = 'a * evar_universe_context
-
-val evar_universe_context_set : Univ.universe_context -> evar_universe_context -> Univ.universe_context_set
-val evar_universe_context_constraints : evar_universe_context -> Univ.constraints
-val evar_context_universe_context : evar_universe_context -> Univ.universe_context
-val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context
-val empty_evar_universe_context : evar_universe_context
-val union_evar_universe_context : evar_universe_context -> evar_universe_context ->
- evar_universe_context
-val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst
-
-val evar_universe_context_of_binders :
- Universes.universe_binders -> evar_universe_context
-
-val make_evar_universe_context : env -> (Id.t located) list option -> evar_universe_context
-val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map
-(** Raises Not_found if not a name for a universe in this map. *)
-val universe_of_name : evar_map -> string -> Univ.universe_level
-val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map
-
-val universes : evar_map -> Univ.universes
-
-val add_constraints_context : evar_universe_context ->
- Univ.constraints -> evar_universe_context
-
-
-val normalize_evar_universe_context_variables : evar_universe_context ->
- Univ.universe_subst in_evar_universe_context
-
-val normalize_evar_universe_context : evar_universe_context ->
- evar_universe_context
-
-val new_univ_level_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level
-val new_univ_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe
-val new_sort_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * sorts
-val add_global_univ : evar_map -> Univ.Level.t -> evar_map
-
-val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map
-val is_sort_variable : evar_map -> sorts -> Univ.universe_level option
-(** [is_sort_variable evm s] returns [Some u] or [None] if [s] is
- not a local sort variable declared in [evm] *)
-val is_flexible_level : evar_map -> Univ.Level.t -> bool
-
-val whd_sort_variable : evar_map -> constr -> constr
-(* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *)
-val normalize_universe : evar_map -> Univ.universe -> Univ.universe
-val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance
-
-val set_leq_sort : env -> evar_map -> sorts -> sorts -> evar_map
-val set_eq_sort : env -> evar_map -> sorts -> sorts -> evar_map
-val has_lub : evar_map -> Univ.universe -> Univ.universe -> evar_map
-val set_eq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map
-val set_leq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map
-val set_eq_instances : ?flex:bool ->
- evar_map -> Univ.universe_instance -> Univ.universe_instance -> evar_map
-
-val check_eq : evar_map -> Univ.universe -> Univ.universe -> bool
-val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool
-
-val evar_universe_context : evar_map -> evar_universe_context
-val universe_context_set : evar_map -> Univ.universe_context_set
-val universe_context : ?names:(Id.t located) list -> evar_map ->
- (Id.t * Univ.Level.t) list * Univ.universe_context
-val universe_subst : evar_map -> Universes.universe_opt_subst
-val universes : evar_map -> Univ.universes
-
-
-val merge_universe_context : evar_map -> evar_universe_context -> evar_map
-val set_universe_context : evar_map -> evar_universe_context -> evar_map
-
-val merge_context_set : ?sideff:bool -> rigid -> evar_map -> Univ.universe_context_set -> evar_map
-val merge_universe_subst : evar_map -> Universes.universe_opt_subst -> evar_map
-
-val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a
-
-val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst
-val abstract_undefined_variables : evar_universe_context -> evar_universe_context
-
-val fix_undefined_variables : evar_map -> evar_map
-
-val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst
-
-val nf_constraints : evar_map -> evar_map
-
-val update_sigma_env : evar_map -> env -> evar_map
-
-(** Polymorphic universes *)
-
-val fresh_sort_in_family : ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts
-val fresh_constant_instance : env -> evar_map -> constant -> evar_map * pconstant
-val fresh_inductive_instance : env -> evar_map -> inductive -> evar_map * pinductive
-val fresh_constructor_instance : env -> evar_map -> constructor -> evar_map * pconstructor
-
-val fresh_global : ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map ->
- Globnames.global_reference -> evar_map * constr
-
-(********************************************************************
- Conversion w.r.t. an evar map, not unifying universes. See
- [Reductionops.infer_conv] for conversion up-to universes. *)
-
-val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool
-(** WARNING: This does not allow unification of universes *)
-
-val eq_constr_univs : evar_map -> constr -> constr -> evar_map * bool
-(** Syntactic equality up to universes, recording the associated constraints *)
-
-val e_eq_constr_univs : evar_map ref -> constr -> constr -> bool
-(** Syntactic equality up to universes. *)
-
-(********************************************************************)
-(* constr with holes and pending resolution of classes, conversion *)
-(* problems, candidates, etc. *)
-
-type pending = (* before: *) evar_map * (* after: *) evar_map
-
-type pending_constr = pending * constr
-
-type open_constr = evar_map * constr (* Special case when before is empty *)
-
-(** Partially constructed constrs. *)
-
-type unsolvability_explanation = SeveralInstancesFound of int
-(** Failure explanation. *)
-
-val pr_existential_key : evar_map -> evar -> Pp.std_ppcmds
-
-(** {5 Debug pretty-printers} *)
-
-val pr_evar_info : evar_info -> Pp.std_ppcmds
-val pr_evar_constraints : evar_constraint list -> Pp.std_ppcmds
-val pr_evar_map : ?with_univs:bool -> int option -> evar_map -> Pp.std_ppcmds
-val pr_evar_map_filter : ?with_univs:bool -> (Evar.t -> evar_info -> bool) ->
- evar_map -> Pp.std_ppcmds
-val pr_metaset : Metaset.t -> Pp.std_ppcmds
-val pr_evar_universe_context : evar_universe_context -> Pp.std_ppcmds
-val pr_evd_level : evar_map -> Univ.Level.t -> Pp.std_ppcmds
-
-(** {5 Deprecated functions} *)
-
-val create_evar_defs : evar_map -> evar_map
-(** Create an [evar_map] with empty meta map: *)
-
-val create_goal_evar_defs : evar_map -> evar_map
diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml
index 6733b7fc..4caa1e99 100644
--- a/pretyping/find_subterm.ml
+++ b/pretyping/find_subterm.ml
@@ -8,7 +8,7 @@
open Pp
open Util
-open Errors
+open CErrors
open Names
open Locus
open Term
@@ -59,19 +59,22 @@ let proceed_with_occurrences f occs x =
(** Applying a function over a named_declaration with an hypothesis
location request *)
-let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) =
- let f = f (Some (id,hyploc)) in
- match bodyopt,hyploc with
- | None, InHypValueOnly ->
+let map_named_declaration_with_hyploc f hyploc acc decl =
+ let open Context.Named.Declaration in
+ let f = f (Some (get_id decl, hyploc)) in
+ match decl,hyploc with
+ | LocalAssum (id,_), InHypValueOnly ->
error_occurrences_error (IncorrectInValueOccurrence id)
- | None, _ | Some _, InHypTypeOnly ->
- let acc,typ = f acc typ in acc,(id,bodyopt,typ)
- | Some body, InHypValueOnly ->
- let acc,body = f acc body in acc,(id,Some body,typ)
- | Some body, InHyp ->
+ | LocalAssum (id,typ), _ ->
+ let acc,typ = f acc typ in acc, LocalAssum (id,typ)
+ | LocalDef (id,body,typ), InHypTypeOnly ->
+ let acc,typ = f acc typ in acc, LocalDef (id,body,typ)
+ | LocalDef (id,body,typ), InHypValueOnly ->
+ let acc,body = f acc body in acc, LocalDef (id,body,typ)
+ | LocalDef (id,body,typ), InHyp ->
let acc,body = f acc body in
let acc,typ = f acc typ in
- acc,(id,Some body,typ)
+ acc, LocalDef (id,body,typ)
(** Finding a subterm up to some testing function *)
@@ -105,7 +108,6 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t =
raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in
let rec substrec k t =
if nowhere_except_in && !pos > maxocc then t else
- if not (Vars.closed0 t) then subst_below k t else
try
let subst = test.match_fun test.testing_state t in
if Locusops.is_selected !pos occs then
diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli
index 28108f8c..c741ab04 100644
--- a/pretyping/find_subterm.mli
+++ b/pretyping/find_subterm.mli
@@ -7,7 +7,6 @@
(************************************************************************)
open Locus
-open Context
open Term
open Evd
open Pretype_errors
@@ -50,7 +49,7 @@ val replace_term_occ_modulo : occurrences or_like_first ->
val replace_term_occ_decl_modulo :
(occurrences * hyp_location_flag) or_like_first ->
'a testing_function -> (unit -> constr) ->
- named_declaration -> named_declaration
+ Context.Named.Declaration.t -> Context.Named.Declaration.t
(** [subst_closed_term_occ occl c d] replaces occurrences of
closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC),
@@ -62,7 +61,7 @@ val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first ->
closed [c] at positions [occl] by [Rel 1] in [decl]. *)
val subst_closed_term_occ_decl : env -> evar_map ->
(occurrences * hyp_location_flag) or_like_first ->
- constr -> named_declaration -> named_declaration * evar_map
+ constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map
(** Miscellaneous *)
val error_invalid_occurrence : int list -> 'a
diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml
index c9860864..51660818 100644
--- a/pretyping/glob_ops.ml
+++ b/pretyping/glob_ops.ml
@@ -266,7 +266,7 @@ let add_name_to_ids set na =
| Anonymous -> set
| Name id -> Id.Set.add id set
-let free_glob_vars =
+let free_glob_vars =
let rec vars bounded vs = function
| GVar (loc,id') -> if Id.Set.mem id' bounded then vs else Id.Set.add id' vs
| GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args)
@@ -324,10 +324,24 @@ let free_glob_vars =
let vs = vars Id.Set.empty Id.Set.empty rt in
Id.Set.elements vs
+let glob_visible_short_qualid c =
+ let rec aux acc = function
+ | GRef (_,c,_) ->
+ let qualid = Nametab.shortest_qualid_of_global Id.Set.empty c in
+ let dir,id = Libnames.repr_qualid qualid in
+ if DirPath.is_empty dir then id :: acc else acc
+ | c ->
+ fold_glob_constr aux acc c
+ in aux [] c
+
+let warn_variable_collision =
+ let open Pp in
+ CWarnings.create ~name:"variable-collision" ~category:"ltac"
+ (fun name ->
+ strbrk "Collision between bound variables of name " ++ pr_id name)
+
let add_and_check_ident id set =
- if Id.Set.mem id set then
- Pp.(msg_warning
- (str "Collision between bound variables of name " ++ Id.print id));
+ if Id.Set.mem id set then warn_variable_collision id;
Id.Set.add id set
let bound_glob_vars =
@@ -456,6 +470,78 @@ let loc_of_glob_constr = function
| GCast (loc,_,_) -> loc
(**********************************************************************)
+(* Alpha-renaming *)
+
+let collide_id l id = List.exists (fun (id',id'') -> Id.equal id id' || Id.equal id id'') l
+let test_id l id = if collide_id l id then raise Not_found
+let test_na l na = name_iter (test_id l) na
+
+let update_subst na l =
+ let in_range id l = List.exists (fun (_,id') -> Id.equal id id') l in
+ let l' = name_fold Id.List.remove_assoc na l in
+ name_fold
+ (fun id _ ->
+ if in_range id l' then
+ let id' = Namegen.next_ident_away_from id (fun id' -> in_range id' l') in
+ Name id', (id,id')::l
+ else na,l)
+ na (na,l)
+
+exception UnsoundRenaming
+
+let rename_var l id =
+ try
+ let id' = Id.List.assoc id l in
+ (* Check that no other earlier binding hide the one found *)
+ let _,(id'',_) = List.extract_first (fun (_,id) -> Id.equal id id') l in
+ if Id.equal id id'' then id' else raise UnsoundRenaming
+ with Not_found ->
+ if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming
+ else id
+
+let rec rename_glob_vars l = function
+ | GVar (loc,id) as r ->
+ let id' = rename_var l id in
+ if id == id' then r else GVar (loc,id')
+ | GRef (_,VarRef id,_) as r ->
+ if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming
+ else r
+ | GProd (loc,na,bk,t,c) ->
+ let na',l' = update_subst na l in
+ GProd (loc,na,bk,rename_glob_vars l t,rename_glob_vars l' c)
+ | GLambda (loc,na,bk,t,c) ->
+ let na',l' = update_subst na l in
+ GLambda (loc,na',bk,rename_glob_vars l t,rename_glob_vars l' c)
+ | GLetIn (loc,na,b,c) ->
+ let na',l' = update_subst na l in
+ GLetIn (loc,na',rename_glob_vars l b,rename_glob_vars l' c)
+ (* Lazy strategy: we fail if a collision with renaming occurs, rather than renaming further *)
+ | GCases (loc,ci,po,tomatchl,cls) ->
+ let test_pred_pat (na,ino) =
+ test_na l na; Option.iter (fun (_,_,nal) -> List.iter (test_na l) nal) ino in
+ let test_clause idl = List.iter (test_id l) idl in
+ let po = Option.map (rename_glob_vars l) po in
+ let tomatchl = Util.List.map_left (fun (tm,x) -> test_pred_pat x; (rename_glob_vars l tm,x)) tomatchl in
+ let cls = Util.List.map_left (fun (loc,idl,p,c) -> test_clause idl; (loc,idl,p,rename_glob_vars l c)) cls in
+ GCases (loc,ci,po,tomatchl,cls)
+ | GLetTuple (loc,nal,(na,po),c,b) ->
+ List.iter (test_na l) (na::nal);
+ GLetTuple (loc,nal,(na,Option.map (rename_glob_vars l) po),
+ rename_glob_vars l c,rename_glob_vars l b)
+ | GIf (loc,c,(na,po),b1,b2) ->
+ test_na l na;
+ GIf (loc,rename_glob_vars l c,(na,Option.map (rename_glob_vars l) po),
+ rename_glob_vars l b1,rename_glob_vars l b2)
+ | GRec (loc,k,idl,decls,bs,ts) ->
+ Array.iter (test_id l) idl;
+ GRec (loc,k,idl,
+ Array.map (List.map (fun (na,k,bbd,bty) ->
+ test_na l na; (na,k,Option.map (rename_glob_vars l) bbd,rename_glob_vars l bty))) decls,
+ Array.map (rename_glob_vars l) bs,
+ Array.map (rename_glob_vars l) ts)
+ | r -> map_glob_constr (rename_glob_vars l) r
+
+(**********************************************************************)
(* Conversion from glob_constr to cases pattern, if possible *)
let rec cases_pattern_of_glob_constr na = function
diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli
index 45444234..55e6b653 100644
--- a/pretyping/glob_ops.mli
+++ b/pretyping/glob_ops.mli
@@ -34,12 +34,25 @@ val map_glob_constr :
val map_glob_constr_left_to_right :
(glob_constr -> glob_constr) -> glob_constr -> glob_constr
+val warn_variable_collision : ?loc:Loc.t -> Id.t -> unit
+
val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a
val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit
val occur_glob_constr : Id.t -> glob_constr -> bool
val free_glob_vars : glob_constr -> Id.t list
val bound_glob_vars : glob_constr -> Id.Set.t
val loc_of_glob_constr : glob_constr -> Loc.t
+val glob_visible_short_qualid : glob_constr -> Id.t list
+
+(* Renaming free variables using a renaming map; fails with
+ [UnsoundRenaming] if applying the renaming would introduce
+ collision, as in, e.g., renaming [P x y] using substitution [(x,y)];
+ inner alpha-conversion done only for forall, fun, let but
+ not for cases and fix *)
+
+exception UnsoundRenaming
+val rename_var : (Id.t * Id.t) list -> Id.t -> Id.t
+val rename_glob_vars : (Id.t * Id.t) list -> glob_constr -> glob_constr
(** [map_pattern_binders f m c] applies [f] to all the binding names
in a pattern-matching expression ({!Glob_term.GCases}) represented
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index d5f6e9b3..39aeb41f 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -11,7 +11,7 @@
(* This file builds various inductive schemes *)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Libnames
@@ -19,7 +19,6 @@ open Globnames
open Nameops
open Term
open Vars
-open Context
open Namegen
open Declarations
open Declareops
@@ -28,6 +27,8 @@ open Inductiveops
open Environ
open Reductionops
open Nametab
+open Sigma.Notations
+open Context.Rel.Declaration
type dep_flag = bool
@@ -35,12 +36,14 @@ type dep_flag = bool
type recursion_scheme_error =
| NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive
| NotMutualInScheme of inductive * inductive
+ | NotAllowedDependentAnalysis of (*isrec:*) bool * inductive
exception RecursionSchemeError of recursion_scheme_error
let make_prod_dep dep env = if dep then mkProd_name env else mkProd
let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c)
+
(*******************************************)
(* Building curryfied elimination *)
(*******************************************)
@@ -60,7 +63,7 @@ let check_privacy_block mib =
let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in
- let indf = make_ind_family(pind, Termops.extended_rel_list 0 lnamespar) in
+ let indf = make_ind_family(pind, Context.Rel.to_extended_list 0 lnamespar) in
let constrs = get_constructors env indf in
let projs = get_projections env indf in
@@ -77,7 +80,6 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
(* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
let env' = push_rel_context lnamespar env in
-
let rec add_branch env k =
if Int.equal k (Array.length mip.mind_consnames) then
let nbprod = k+1 in
@@ -85,14 +87,14 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
let indf' = lift_inductive_family nbprod indf in
let arsign,_ = get_arity env indf' in
let depind = build_dependent_inductive env indf' in
- let deparsign = (Anonymous,None,depind)::arsign in
+ let deparsign = LocalAssum (Anonymous,depind)::arsign in
let ci = make_case_info env (fst pind) RegularStyle in
let pbody =
appvect
(mkRel (ndepar + nbprod),
- if dep then Termops.extended_rel_vect 0 deparsign
- else Termops.extended_rel_vect 1 arsign) in
+ if dep then Context.Rel.to_extended_vect 0 deparsign
+ else Context.Rel.to_extended_vect 1 arsign) in
let p =
it_mkLambda_or_LetIn_name env'
((if dep then mkLambda_name env' else mkLambda)
@@ -118,15 +120,16 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
let cs = lift_constructor (k+1) constrs.(k) in
let t = build_branch_type env dep (mkRel (k+1)) cs in
mkLambda_string "f" t
- (add_branch (push_rel (Anonymous, None, t) env) (k+1))
+ (add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1))
in
- let sigma, s = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
+ let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
let typP = make_arity env' dep indf s in
let c =
it_mkLambda_or_LetIn_name env
(mkLambda_string "P" typP
- (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar
- in sigma, c
+ (add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar
+ in
+ Sigma (c, sigma, p)
(* check if the type depends recursively on one of the inductive scheme *)
@@ -150,23 +153,26 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
let nparams = List.length vargs in
let process_pos env depK pk =
let rec prec env i sign p =
- let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
+ let p',largs = whd_allnolet_stack env sigma p in
match kind_of_term p' with
| Prod (n,t,c) ->
- let d = (n,None,t) in
+ let d = LocalAssum (n,t) in
make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c)
- | LetIn (n,b,t,c) ->
- let d = (n,Some b,t) in
+ | LetIn (n,b,t,c) when List.is_empty largs ->
+ let d = LocalDef (n,b,t) in
mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c)
| Ind (_,_) ->
let realargs = List.skipn nparams largs in
let base = applist (lift i pk,realargs) in
if depK then
Reduction.beta_appvect
- base [|applist (mkRel (i+1), Termops.extended_rel_list 0 sign)|]
+ base [|applist (mkRel (i+1), Context.Rel.to_extended_list 0 sign)|]
else
base
- | _ -> assert false
+ | _ ->
+ let t' = whd_all env sigma p in
+ if Term.eq_constr p' t' then assert false
+ else prec env i sign t'
in
prec env 0 []
in
@@ -179,31 +185,29 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
| ra::rest ->
(match dest_recarg ra with
| Mrec (_,j) when is_rec -> (depPvect.(j),rest)
- | Imbr _ ->
- msg_warning (strbrk "Ignoring recursive call");
- (None,rest)
+ | Imbr _ -> (None,rest)
| _ -> (None, rest))
in
(match optionpos with
| None ->
make_prod env
(n,t,
- process_constr (push_rel (n,None,t) env) (i+1) c_0 rest
+ process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest
(nhyps-1) (i::li))
| Some(dep',p) ->
let nP = lift (i+1+decP) p in
- let env' = push_rel (n,None,t) env in
+ let env' = push_rel (LocalAssum (n,t)) env in
let t_0 = process_pos env' dep' nP (lift 1 t) in
make_prod_dep (dep || dep') env
(n,t,
mkArrow t_0
(process_constr
- (push_rel (Anonymous,None,t_0) env')
+ (push_rel (LocalAssum (Anonymous,t_0)) env')
(i+2) (lift 1 c_0) rest (nhyps-1) (i::li))))
| LetIn (n,b,t,c_0) ->
mkLetIn (n,b,t,
process_constr
- (push_rel (n,Some b,t) env)
+ (push_rel (LocalDef (n,b,t)) env)
(i+1) c_0 recargs (nhyps-1) li)
| _ -> assert false
else
@@ -225,25 +229,28 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
let process_pos env fk =
let rec prec env i hyps p =
- let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
+ let p',largs = whd_allnolet_stack env sigma p in
match kind_of_term p' with
| Prod (n,t,c) ->
- let d = (n,None,t) in
+ let d = LocalAssum (n,t) in
mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c)
- | LetIn (n,b,t,c) ->
- let d = (n,Some b,t) in
+ | LetIn (n,b,t,c) when List.is_empty largs ->
+ let d = LocalDef (n,b,t) in
mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
| Ind _ ->
let realargs = List.skipn nparrec largs
- and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in
+ and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect 0 hyps) in
applist(lift i fk,realargs@[arg])
- | _ -> assert false
+ | _ ->
+ let t' = whd_all env sigma p in
+ if Term.eq_constr t' p' then assert false
+ else prec env i hyps t'
in
prec env 0 []
in
(* ici, cstrprods est la liste des produits du constructeur instantié *)
let rec process_constr env i f = function
- | (n,None,t as d)::cprest, recarg::rest ->
+ | (LocalAssum (n,t) as d)::cprest, recarg::rest ->
let optionpos =
match dest_recarg recarg with
| Norec -> None
@@ -264,7 +271,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
(n,t,process_constr env' (i+1)
(whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1); arg])))
(cprest,rest)))
- | (n,Some c,t as d)::cprest, rest ->
+ | (LocalDef (n,c,t) as d)::cprest, rest ->
mkLetIn
(n,c,t,
process_constr (push_rel d env) (i+1) (lift 1 f)
@@ -275,24 +282,13 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
in
process_constr env 0 f (List.rev cstr.cs_args, recargs)
-
-(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k
- variables *)
-let context_chop k ctx =
- let rec chop_aux acc = function
- | (0, l2) -> (List.rev acc, l2)
- | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t)
- | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
- | (_, []) -> failwith "context_chop"
- in chop_aux [] (k,ctx)
-
(* Main function *)
let mis_make_indrec env sigma listdepkind mib u =
let nparams = mib.mind_nparams in
let nparrec = mib.mind_nparams_rec in
let evdref = ref sigma in
let lnonparrec,lnamesparrec =
- context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in
+ Termops.context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in
let nrec = List.length listdepkind in
let depPvec =
Array.make mib.mind_ntypes (None : (bool * constr) option) in
@@ -321,29 +317,29 @@ let mis_make_indrec env sigma listdepkind mib u =
(* arity in the context of the fixpoint, i.e.
P1..P_nrec f1..f_nbconstruct *)
- let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in
+ let args = Context.Rel.to_extended_list (nrec+nbconstruct) lnamesparrec in
let indf = make_ind_family((indi,u),args) in
let arsign,_ = get_arity env indf in
let depind = build_dependent_inductive env indf in
- let deparsign = (Anonymous,None,depind)::arsign in
+ let deparsign = LocalAssum (Anonymous,depind)::arsign in
- let nonrecpar = rel_context_length lnonparrec in
- let larsign = rel_context_length deparsign in
+ let nonrecpar = Context.Rel.length lnonparrec in
+ let larsign = Context.Rel.length deparsign in
let ndepar = larsign - nonrecpar in
let dect = larsign+nrec+nbconstruct in
(* constructors in context of the Cases expr, i.e.
P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *)
- let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in
- let args'' = Termops.extended_rel_list ndepar lnonparrec in
+ let args' = Context.Rel.to_extended_list (dect+nrec) lnamesparrec in
+ let args'' = Context.Rel.to_extended_list ndepar lnonparrec in
let indf' = make_ind_family((indi,u),args'@args'') in
let branches =
let constrs = get_constructors env indf' in
let fi = Termops.rel_vect (dect-i-nctyi) nctyi in
let vecfi = Array.map
- (fun f -> appvect (f, Termops.extended_rel_vect ndepar lnonparrec))
+ (fun f -> appvect (f, Context.Rel.to_extended_vect ndepar lnonparrec))
fi
in
Array.map3
@@ -361,12 +357,12 @@ let mis_make_indrec env sigma listdepkind mib u =
let depind' = build_dependent_inductive env indf' in
let arsign',_ = get_arity env indf' in
- let deparsign' = (Anonymous,None,depind')::arsign' in
+ let deparsign' = LocalAssum (Anonymous,depind')::arsign' in
let pargs =
- let nrpar = Termops.extended_rel_list (2*ndepar) lnonparrec
- and nrar = if dep then Termops.extended_rel_list 0 deparsign'
- else Termops.extended_rel_list 1 arsign'
+ let nrpar = Context.Rel.to_extended_list (2*ndepar) lnonparrec
+ and nrar = if dep then Context.Rel.to_extended_list 0 deparsign'
+ else Context.Rel.to_extended_list 1 arsign'
in nrpar@nrar
in
@@ -381,25 +377,9 @@ let mis_make_indrec env sigma listdepkind mib u =
(Anonymous,depind',concl))
arsign'
in
- let obj =
- let projs = get_projections env indf in
- match projs with
- | None -> (mkCase (ci, pred,
- mkRel 1,
- branches))
- | Some ps ->
- let branch = branches.(0) in
- let ctx, br = decompose_lam_assum branch in
- let n, subst =
- List.fold_right (fun (na,b,t) (i, subst) ->
- if b == None then
- let t = mkProj (Projection.make ps.(i) true, mkRel 1) in
- (i + 1, t :: subst)
- else (i, mkRel 0 :: subst))
- ctx (0, [])
- in
- let term = substl subst br in
- term
+ let obj =
+ Inductiveops.make_case_or_project env indf ci pred
+ (mkRel 1) branches
in
it_mkLambda_or_LetIn_name env obj
(Termops.lift_rel_context nrec deparsign)
@@ -409,14 +389,14 @@ let mis_make_indrec env sigma listdepkind mib u =
let typtyi =
let concl =
- let pargs = if dep then Termops.extended_rel_vect 0 deparsign
- else Termops.extended_rel_vect 1 arsign
+ let pargs = if dep then Context.Rel.to_extended_vect 0 deparsign
+ else Context.Rel.to_extended_vect 1 arsign
in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs)
in it_mkProd_or_LetIn_name env
concl
deparsign
in
- mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp)
+ mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (typtyi::ltyp)
(deftyi::ldef) rest
| [] ->
let fixn = Array.of_list (List.rev ln) in
@@ -437,28 +417,28 @@ let mis_make_indrec env sigma listdepkind mib u =
else
let recarg = (dest_subterms recargsvec.(tyi)).(j) in
let recarg = recargpar@recarg in
- let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in
+ let vargs = Context.Rel.to_extended_list (nrec+i+j) lnamesparrec in
let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in
let p_0 =
type_rec_branch
true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg
in
mkLambda_string "f" p_0
- (onerec (push_rel (Anonymous,None,p_0) env) (j+1))
+ (onerec (push_rel (LocalAssum (Anonymous,p_0)) env) (j+1))
in onerec env 0
| [] ->
makefix i listdepkind
in
let rec put_arity env i = function
| ((indi,u),_,_,dep,kinds)::rest ->
- let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in
+ let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list i lnamesparrec) in
let s =
Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env)
evdref kinds
in
let typP = make_arity env dep indf s in
mkLambda_string "P" typP
- (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest)
+ (put_arity (push_rel (LocalAssum (Anonymous,typP)) env) (i+1) rest)
| [] ->
make_branch env 0 listdepkind
in
@@ -474,7 +454,9 @@ let mis_make_indrec env sigma listdepkind mib u =
it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind)
lnamesparrec
else
- let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in
+ let sigma = Sigma.Unsafe.of_evar_map !evdref in
+ let Sigma (c, sigma, _) = mis_make_case_com dep env sigma (indi,u) (mibi,mipi) kind in
+ let evd' = Sigma.to_evar_map sigma in
evdref := evd'; c
in
(* Body of mis_make_indrec *)
@@ -485,6 +467,8 @@ let mis_make_indrec env sigma listdepkind mib u =
let build_case_analysis_scheme env sigma pity dep kind =
let (mib,mip) = lookup_mind_specif env (fst pity) in
+ if dep && not (Inductiveops.has_dependent_elim mib) then
+ raise (RecursionSchemeError (NotAllowedDependentAnalysis (false, fst pity)));
mis_make_case_com dep env sigma pity (mib,mip) kind
let is_in_prop mip =
@@ -494,7 +478,7 @@ let is_in_prop mip =
let build_case_analysis_scheme_default env sigma pity kind =
let (mib,mip) = lookup_mind_specif env (fst pity) in
- let dep = not (is_in_prop mip) in
+ let dep = not (is_in_prop mip || not (Inductiveops.has_dependent_elim mib)) in
mis_make_case_com dep env sigma pity (mib,mip) kind
(**********************************************************************)
@@ -555,6 +539,8 @@ let check_arities env listdepkind =
let build_mutual_induction_scheme env sigma = function
| ((mind,u),dep,s)::lrecspec ->
let (mib,mip) = lookup_mind_specif env mind in
+ if dep && not (Inductiveops.has_dependent_elim mib) then
+ raise (RecursionSchemeError (NotAllowedDependentAnalysis (true, mind)));
let (sp,tyi) = mind in
let listdepkind =
((mind,u),mib,mip,dep,s)::
@@ -574,6 +560,8 @@ let build_mutual_induction_scheme env sigma = function
let build_induction_scheme env sigma pind dep kind =
let (mib,mip) = lookup_mind_specif env (fst pind) in
+ if dep && not (Inductiveops.has_dependent_elim mib) then
+ raise (RecursionSchemeError (NotAllowedDependentAnalysis (true, fst pind)));
let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in
sigma, List.hd l
@@ -592,7 +580,7 @@ let make_elimination_ident id s = add_suffix id (elimination_suffix s)
let lookup_eliminator ind_sp s =
let kn,i = ind_sp in
- let mp,dp,l = repr_mind kn in
+ let mp,dp,l = KerName.repr (MutInd.canonical kn) in
let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in
let id = add_suffix ind_id (elimination_suffix s) in
(* Try first to get an eliminator defined in the same section as the *)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index 4d81a59e..192b64a5 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -16,6 +16,7 @@ open Evd
type recursion_scheme_error =
| NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive
| NotMutualInScheme of inductive * inductive
+ | NotAllowedDependentAnalysis of (*isrec:*) bool * inductive
exception RecursionSchemeError of recursion_scheme_error
@@ -25,16 +26,18 @@ type dep_flag = bool
(** Build a case analysis elimination scheme in some sort family *)
-val build_case_analysis_scheme : env -> evar_map -> pinductive ->
- dep_flag -> sorts_family -> evar_map * constr
+val build_case_analysis_scheme : env -> 'r Sigma.t -> pinductive ->
+ dep_flag -> sorts_family -> (constr, 'r) Sigma.sigma
-(** Build a dependent case elimination predicate unless type is in Prop *)
+(** Build a dependent case elimination predicate unless type is in Prop
+ or is a recursive record with primitive projections. *)
-val build_case_analysis_scheme_default : env -> evar_map -> pinductive ->
- sorts_family -> evar_map * constr
+val build_case_analysis_scheme_default : env -> 'r Sigma.t -> pinductive ->
+ sorts_family -> (constr, 'r) Sigma.sigma
(** Builds a recursive induction scheme (Peano-induction style) in the same
- sort family as the inductive family; it is dependent if not in Prop *)
+ sort family as the inductive family; it is dependent if not in Prop
+ or a recursive record with primitive projections. *)
val build_induction_scheme : env -> evar_map -> pinductive ->
dep_flag -> sorts_family -> evar_map * constr
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index fb180b8b..214e19fe 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -6,18 +6,18 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Univ
open Term
open Vars
-open Context
open Termops
open Declarations
open Declareops
open Environ
open Reductionops
+open Context.Rel.Declaration
(* The following three functions are similar to the ones defined in
Inductive, but they expect an env *)
@@ -142,12 +142,12 @@ let constructor_nallargs_env env ((kn,i),j) =
let constructor_nalldecls (indsp,j) = (* TOCHANGE en decls *)
let (mib,mip) = Global.lookup_inductive indsp in
- mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt)
+ mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt)
let constructor_nalldecls_env env ((kn,i),j) = (* TOCHANGE en decls *)
let mib = Environ.lookup_mind kn env in
let mip = mib.mind_packets.(i) in
- mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt)
+ mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt)
(* Arity of constructors excluding params, excluding local defs *)
@@ -213,21 +213,21 @@ let inductive_nparams_env env ind =
let inductive_nparamdecls ind =
let (mib,mip) = Global.lookup_inductive ind in
- rel_context_length mib.mind_params_ctxt
+ Context.Rel.length mib.mind_params_ctxt
let inductive_nparamdecls_env env ind =
let (mib,mip) = Inductive.lookup_mind_specif env ind in
- rel_context_length mib.mind_params_ctxt
+ Context.Rel.length mib.mind_params_ctxt
(* Full length of arity (with local defs) *)
let inductive_nalldecls ind =
let (mib,mip) = Global.lookup_inductive ind in
- rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls
+ Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls
let inductive_nalldecls_env env ind =
let (mib,mip) = Inductive.lookup_mind_specif env ind in
- rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls
+ Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls
(* Others *)
@@ -249,13 +249,13 @@ let inductive_alldecls_env env (ind,u) =
let constructor_has_local_defs (indsp,j) =
let (mib,mip) = Global.lookup_inductive indsp in
- let l1 = mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt) in
+ let l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) in
let l2 = recarg_length mip.mind_recargs j + mib.mind_nparams in
not (Int.equal l1 l2)
let inductive_has_local_defs ind =
let (mib,mip) = Global.lookup_inductive ind in
- let l1 = rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls in
+ let l1 = Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls in
let l2 = mib.mind_nparams + mip.mind_nrealargs in
not (Int.equal l1 l2)
@@ -269,15 +269,20 @@ let projection_nparams_env env p =
let projection_nparams p = projection_nparams_env (Global.env ()) p
+let has_dependent_elim mib =
+ match mib.mind_record with
+ | Some (Some _) -> mib.mind_finite == Decl_kinds.BiFinite
+ | _ -> true
+
(* Annotation for cases *)
let make_case_info env ind style =
let (mib,mip) = Inductive.lookup_mind_specif env ind in
let ind_tags =
- rel_context_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in
+ Context.Rel.to_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in
let cstr_tags =
Array.map2 (fun c n ->
let d,_ = decompose_prod_assum c in
- rel_context_tags (List.firstn n d))
+ Context.Rel.to_tags (List.firstn n d))
mip.mind_nf_lc mip.mind_consnrealdecls in
let print_info = { ind_tags; cstr_tags; style } in
{ ci_ind = ind;
@@ -292,7 +297,7 @@ type constructor_summary = {
cs_cstr : pconstructor;
cs_params : constr list;
cs_nargs : int;
- cs_args : rel_context;
+ cs_args : Context.Rel.t;
cs_concl_realargs : constr array
}
@@ -303,21 +308,15 @@ let lift_constructor n cs = {
cs_args = lift_rel_context n cs.cs_args;
cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs
}
-(* Accept less parameters than in the signature *)
-
-let instantiate_params t args sign =
- let rec inst s t = function
- | ((_,None,_)::ctxt,a::args) ->
- (match kind_of_term t with
- | Prod(_,_,t) -> inst (a::s) t (ctxt,args)
- | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch"))
- | ((_,(Some b),_)::ctxt,args) ->
- (match kind_of_term t with
- | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args)
- | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch"))
- | _, [] -> substl s t
- | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch")
- in inst [] t (List.rev sign,args)
+
+(* Accept either all parameters or only recursively uniform ones *)
+let instantiate_params t params sign =
+ let nnonrecpar = Context.Rel.nhyps sign - List.length params in
+ (* Adjust the signature if recursively non-uniform parameters are not here *)
+ let _,sign = context_chop nnonrecpar sign in
+ let _,t = decompose_prod_n_assum (Context.Rel.length sign) t in
+ let subst = subst_of_rel_context_instance sign params in
+ substl subst t
let get_constructor ((ind,u as indu),mib,mip,params) j =
assert (j <= Array.length mip.mind_consnames);
@@ -329,7 +328,7 @@ let get_constructor ((ind,u as indu),mib,mip,params) j =
let vargs = List.skipn (List.length params) allargs in
{ cs_cstr = (ith_constructor_of_inductive ind j,u);
cs_params = params;
- cs_nargs = rel_context_length args;
+ cs_nargs = Context.Rel.length args;
cs_args = args;
cs_concl_realargs = Array.of_list vargs }
@@ -344,6 +343,35 @@ let get_projections env (ind,params) =
| Some (Some (id, projs, pbs)) -> Some projs
| _ -> None
+let make_case_or_project env indf ci pred c branches =
+ let projs = get_projections env indf in
+ match projs with
+ | None -> (mkCase (ci, pred, c, branches))
+ | Some ps ->
+ assert(Array.length branches == 1);
+ let () =
+ let _, _, t = destLambda pred in
+ let (ind, _), _ = dest_ind_family indf in
+ let mib, _ = Inductive.lookup_mind_specif env ind in
+ if (* dependent *) not (noccurn 1 t) &&
+ not (has_dependent_elim mib) then
+ errorlabstrm "make_case_or_project"
+ Pp.(str"Dependent case analysis not allowed" ++
+ str" on inductive type " ++ Names.MutInd.print (fst ind))
+ in
+ let branch = branches.(0) in
+ let ctx, br = decompose_lam_n_assum (Array.length ps) branch in
+ let n, subst =
+ List.fold_right
+ (fun decl (i, subst) ->
+ match decl with
+ | LocalAssum (na, t) ->
+ let t = mkProj (Projection.make ps.(i) true, c) in
+ (i + 1, t :: subst)
+ | LocalDef (na, b, t) -> (i, substl subst b :: subst))
+ ctx (0, [])
+ in substl subst br
+
(* substitution in a signature *)
let substnl_rel_context subst n sign =
@@ -354,14 +382,6 @@ let substnl_rel_context subst n sign =
let substl_rel_context subst = substnl_rel_context subst 0
-let instantiate_context sign args =
- let rec aux subst = function
- | (_,None,_)::sign, a::args -> aux (a::subst) (sign,args)
- | (_,Some b,_)::sign, args -> aux (substl subst b::subst) (sign,args)
- | [], [] -> subst
- | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family")
- in aux [] (List.rev sign,args)
-
let get_arity env ((ind,u),params) =
let (mib,mip) = Inductive.lookup_mind_specif env ind in
let parsign =
@@ -379,7 +399,7 @@ let get_arity env ((ind,u),params) =
let parsign = Vars.subst_instance_context u parsign in
let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in
let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in
- let subst = instantiate_context parsign params in
+ let subst = subst_of_rel_context_instance parsign params in
let arsign = Vars.subst_instance_context u arsign in
(substl_rel_context subst arsign, Inductive.inductive_sort_family mip)
@@ -388,14 +408,14 @@ let build_dependent_constructor cs =
applist
(mkConstructU cs.cs_cstr,
(List.map (lift cs.cs_nargs) cs.cs_params)
- @(extended_rel_list 0 cs.cs_args))
+ @(Context.Rel.to_extended_list 0 cs.cs_args))
let build_dependent_inductive env ((ind, params) as indf) =
let arsign,_ = get_arity env indf in
let nrealargs = List.length arsign in
applist
(mkIndU ind,
- (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign))
+ (List.map (lift nrealargs) params)@(Context.Rel.to_extended_list 0 arsign))
(* builds the arity of an elimination predicate in sort [s] *)
@@ -404,7 +424,7 @@ let make_arity_signature env dep indf =
if dep then
(* We need names everywhere *)
Namegen.name_context env
- ((Anonymous,None,build_dependent_inductive env indf)::arsign)
+ ((LocalAssum (Anonymous,build_dependent_inductive env indf))::arsign)
(* Costly: would be better to name once for all at definition time *)
else
(* No need to enforce names *)
@@ -430,14 +450,17 @@ let extract_mrectype t =
| Ind ind -> (ind, l)
| _ -> raise Not_found
-let find_mrectype env sigma c =
- let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+let find_mrectype_vect env sigma c =
+ let (t, l) = decompose_appvect (whd_all env sigma c) in
match kind_of_term t with
| Ind ind -> (ind, l)
| _ -> raise Not_found
+let find_mrectype env sigma c =
+ let (ind, v) = find_mrectype_vect env sigma c in (ind, Array.to_list v)
+
let find_rectype env sigma c =
- let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+ let (t, l) = decompose_app (whd_all env sigma c) in
match kind_of_term t with
| Ind (ind,u as indu) ->
let (mib,mip) = Inductive.lookup_mind_specif env ind in
@@ -447,7 +470,7 @@ let find_rectype env sigma c =
| _ -> raise Not_found
let find_inductive env sigma c =
- let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+ let (t, l) = decompose_app (whd_all env sigma c) in
match kind_of_term t with
| Ind ind
when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite <> Decl_kinds.CoFinite ->
@@ -455,7 +478,7 @@ let find_inductive env sigma c =
| _ -> raise Not_found
let find_coinductive env sigma c =
- let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+ let (t, l) = decompose_app (whd_all env sigma c) in
match kind_of_term t with
| Ind ind
when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite == Decl_kinds.CoFinite ->
@@ -469,9 +492,9 @@ let find_coinductive env sigma c =
let is_predicate_explicitly_dep env pred arsign =
let rec srec env pval arsign =
- let pv' = whd_betadeltaiota env Evd.empty pval in
+ let pv' = whd_all env Evd.empty pval in
match kind_of_term pv', arsign with
- | Lambda (na,t,b), (_,None,_)::arsign ->
+ | Lambda (na,t,b), (LocalAssum _)::arsign ->
srec (push_rel_assum (na,t) env) b arsign
| Lambda (na,_,t), _ ->
@@ -517,7 +540,7 @@ let set_pattern_names env ind brv =
let arities =
Array.map
(fun c ->
- rel_context_length ((prod_assum c)) -
+ Context.Rel.length ((prod_assum c)) -
mib.mind_nparams)
mip.mind_nf_lc in
Array.map2 (set_names env) arities brv
@@ -529,7 +552,7 @@ let type_case_branches_with_names env indspec p c =
let (params,realargs) = List.chop nparams args in
let lbrty = Inductive.build_branches_type ind specif params p in
(* Build case type *)
- let conclty = Reduction.betazeta_appvect (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in
+ let conclty = lambda_appvect_assum (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in
(* Adjust names *)
if is_elim_predicate_explicitly_dependent env p (ind,params) then
(set_pattern_names env (fst ind) lbrty, conclty)
@@ -551,11 +574,11 @@ let arity_of_case_predicate env (ind,params) dep k =
that appear in the type of the inductive by the sort of the
conclusion, and the other ones by fresh universes. *)
let rec instantiate_universes env evdref scl is = function
- | (_,Some _,_ as d)::sign, exp ->
+ | (LocalDef _ as d)::sign, exp ->
d :: instantiate_universes env evdref scl is (sign, exp)
| d::sign, None::exp ->
d :: instantiate_universes env evdref scl is (sign, exp)
- | (na,None,ty)::sign, Some l::exp ->
+ | (LocalAssum (na,ty))::sign, Some l::exp ->
let ctx,_ = Reduction.dest_arity env ty in
let u = Univ.Universe.make l in
let s =
@@ -569,7 +592,7 @@ let rec instantiate_universes env evdref scl is = function
let evm = Evd.set_leq_sort env evm s (Sorts.sort_of_univ u) in
evdref := evm; s
in
- (na,None,mkArity(ctx,s)):: instantiate_universes env evdref scl is (sign, exp)
+ (LocalAssum (na,mkArity(ctx,s))) :: instantiate_universes env evdref scl is (sign, exp)
| sign, [] -> sign (* Uniform parameters are exhausted *)
| [], _ -> assert false
@@ -603,9 +626,9 @@ let type_of_projection_knowing_arg env sigma p c ty =
let control_only_guard env c =
let check_fix_cofix e c = match kind_of_term c with
| CoFix (_,(_,_,_) as cofix) ->
- Inductive.check_cofix e cofix
+ Inductive.check_cofix e cofix
| Fix (_,(_,_,_) as fix) ->
- Inductive.check_fix e fix
+ Inductive.check_fix e fix
| _ -> ()
in
let rec iter env c =
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 7cd2ff2a..7bd61659 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -8,7 +8,6 @@
open Names
open Term
-open Context
open Declarations
open Environ
open Evd
@@ -92,12 +91,12 @@ val inductive_nparamdecls : inductive -> int
val inductive_nparamdecls_env : env -> inductive -> int
(** @return params context *)
-val inductive_paramdecls : pinductive -> rel_context
-val inductive_paramdecls_env : env -> pinductive -> rel_context
+val inductive_paramdecls : pinductive -> Context.Rel.t
+val inductive_paramdecls_env : env -> pinductive -> Context.Rel.t
(** @return full arity context, hence with letin *)
-val inductive_alldecls : pinductive -> rel_context
-val inductive_alldecls_env : env -> pinductive -> rel_context
+val inductive_alldecls : pinductive -> Context.Rel.t
+val inductive_alldecls_env : env -> pinductive -> Context.Rel.t
(** {7 Extract information from a constructor name} *)
@@ -123,19 +122,24 @@ val inductive_has_local_defs : inductive -> bool
val allowed_sorts : env -> inductive -> sorts_family list
+(** (Co)Inductive records with primitive projections do not have eta-conversion,
+ hence no dependent elimination. *)
+val has_dependent_elim : mutual_inductive_body -> bool
+
(** Primitive projections *)
val projection_nparams : projection -> int
val projection_nparams_env : env -> projection -> int
val type_of_projection_knowing_arg : env -> evar_map -> Projection.t ->
- constr -> types -> types
+ constr -> types -> types
+
(** Extract information from an inductive family *)
type constructor_summary = {
cs_cstr : pconstructor; (* internal name of the constructor plus universes *)
- cs_params : constr list; (* parameters of the constructor in current ctx *)
- cs_nargs : int; (* length of arguments signature (letin included) *)
- cs_args : rel_context; (* signature of the arguments (letin included) *)
+ cs_params : constr list; (* parameters of the constructor in current ctx *)
+ cs_nargs : int; (* length of arguments signature (letin included) *)
+ cs_args : Context.Rel.t; (* signature of the arguments (letin included) *)
cs_concl_realargs : constr array; (* actual realargs in the concl of cstr *)
}
val lift_constructor : int -> constructor_summary -> constructor_summary
@@ -148,17 +152,18 @@ val get_projections : env -> inductive_family -> constant array option
(** [get_arity] returns the arity of the inductive family instantiated
with the parameters; if recursively non-uniform parameters are not
part of the inductive family, they appears in the arity *)
-val get_arity : env -> inductive_family -> rel_context * sorts_family
+val get_arity : env -> inductive_family -> Context.Rel.t * sorts_family
val build_dependent_constructor : constructor_summary -> constr
val build_dependent_inductive : env -> inductive_family -> constr
-val make_arity_signature : env -> bool -> inductive_family -> rel_context
+val make_arity_signature : env -> bool -> inductive_family -> Context.Rel.t
val make_arity : env -> bool -> inductive_family -> sorts -> types
val build_branch_type : env -> bool -> constr -> constructor_summary -> types
(** Raise [Not_found] if not given a valid inductive type *)
val extract_mrectype : constr -> pinductive * constr list
val find_mrectype : env -> evar_map -> types -> pinductive * constr list
+val find_mrectype_vect : env -> evar_map -> types -> pinductive * constr array
val find_rectype : env -> evar_map -> types -> inductive_type
val find_inductive : env -> evar_map -> types -> pinductive * constr list
val find_coinductive : env -> evar_map -> types -> pinductive * constr list
@@ -175,6 +180,14 @@ val type_case_branches_with_names :
(** Annotation for cases *)
val make_case_info : env -> inductive -> case_style -> case_info
+(** Make a case or substitute projections if the inductive type is a record
+ with primitive projections.
+ Fail with an error if the elimination is dependent while the
+ inductive type does not allow dependent elimination. *)
+val make_case_or_project :
+ env -> inductive_family -> case_info ->
+ (* pred *) constr -> (* term *) constr -> (* branches *) constr array -> constr
+
(*i Compatibility
val make_default_case_info : env -> case_style -> inductive -> case_info
i*)
diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml
index d89aeccd..e4fbf8d5 100644
--- a/pretyping/locusops.ml
+++ b/pretyping/locusops.ml
@@ -50,9 +50,9 @@ let is_nowhere = function
let simple_clause_of enum_hyps cl =
let error_occurrences () =
- Errors.error "This tactic does not support occurrences selection" in
+ CErrors.error "This tactic does not support occurrences selection" in
let error_body_selection () =
- Errors.error "This tactic does not support body selection" in
+ CErrors.error "This tactic does not support body selection" in
let hyps =
match cl.onhyps with
| None ->
@@ -84,7 +84,7 @@ let concrete_clause_of enum_hyps cl =
(** Miscellaneous functions *)
let out_arg = function
- | Misctypes.ArgVar _ -> Errors.anomaly (Pp.str "Unevaluated or_var variable")
+ | Misctypes.ArgVar _ -> CErrors.anomaly (Pp.str "Unevaluated or_var variable")
| Misctypes.ArgArg x -> x
let occurrences_of_hyp id cls =
diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml
deleted file mode 100644
index fc3f0cc7..00000000
--- a/pretyping/namegen.ml
+++ /dev/null
@@ -1,395 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* Created from contents that was formerly in termops.ml and
- nameops.ml, Nov 2009 *)
-
-(* This file is about generating new or fresh names and dealing with
- alpha-renaming *)
-
-open Util
-open Names
-open Term
-open Vars
-open Nametab
-open Nameops
-open Libnames
-open Globnames
-open Environ
-open Termops
-
-(**********************************************************************)
-(* Conventional names *)
-
-let default_prop_string = "H"
-let default_prop_ident = Id.of_string default_prop_string
-
-let default_small_string = "H"
-let default_small_ident = Id.of_string default_small_string
-
-let default_type_string = "X"
-let default_type_ident = Id.of_string default_type_string
-
-let default_non_dependent_string = "H"
-let default_non_dependent_ident = Id.of_string default_non_dependent_string
-
-let default_dependent_ident = Id.of_string "x"
-
-(**********************************************************************)
-(* Globality of identifiers *)
-
-let is_imported_modpath = function
- | MPfile dp ->
- let rec find_prefix = function
- |MPfile dp1 -> not (DirPath.equal dp1 dp)
- |MPdot(mp,_) -> find_prefix mp
- |MPbound(_) -> false
- in find_prefix (Lib.current_mp ())
- | _ -> false
-
-let is_imported_ref = function
- | VarRef _ -> false
- | IndRef (kn,_)
- | ConstructRef ((kn,_),_) ->
- let (mp,_,_) = repr_mind kn in is_imported_modpath mp
- | ConstRef kn ->
- let (mp,_,_) = repr_con kn in is_imported_modpath mp
-
-let is_global id =
- try
- let ref = locate (qualid_of_ident id) in
- not (is_imported_ref ref)
- with Not_found ->
- false
-
-let is_constructor id =
- try
- match locate (qualid_of_ident id) with
- | ConstructRef _ -> true
- | _ -> false
- with Not_found ->
- false
-
-(**********************************************************************)
-(* Generating "intuitive" names from its type *)
-
-let head_name c = (* Find the head constant of a constr if any *)
- let rec hdrec c =
- match kind_of_term c with
- | Prod (_,_,c) | Lambda (_,_,c) | LetIn (_,_,_,c)
- | Cast (c,_,_) | App (c,_) -> hdrec c
- | Proj (kn,_) -> Some (Label.to_id (con_label (Projection.constant kn)))
- | Const _ | Ind _ | Construct _ | Var _ ->
- Some (basename_of_global (global_of_constr c))
- | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) ->
- Some (match lna.(i) with Name id -> id | _ -> assert false)
- | Sort _ | Rel _ | Meta _|Evar _|Case (_, _, _, _) -> None
- in
- hdrec c
-
-let lowercase_first_char id = (* First character of a constr *)
- Unicode.lowercase_first_char (Id.to_string id)
-
-let sort_hdchar = function
- | Prop(_) -> "P"
- | Type(_) -> "T"
-
-let hdchar env c =
- let rec hdrec k c =
- match kind_of_term c with
- | Prod (_,_,c) | Lambda (_,_,c) | LetIn (_,_,_,c) -> hdrec (k+1) c
- | Cast (c,_,_) | App (c,_) -> hdrec k c
- | Proj (kn,_) -> lowercase_first_char (Label.to_id (con_label (Projection.constant kn)))
- | Const (kn,_) -> lowercase_first_char (Label.to_id (con_label kn))
- | Ind (x,_) -> lowercase_first_char (basename_of_global (IndRef x))
- | Construct (x,_) -> lowercase_first_char (basename_of_global (ConstructRef x))
- | Var id -> lowercase_first_char id
- | Sort s -> sort_hdchar s
- | Rel n ->
- (if n<=k then "p" (* the initial term is flexible product/function *)
- else
- try match Environ.lookup_rel (n-k) env with
- | (Name id,_,_) -> lowercase_first_char id
- | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t)
- with Not_found -> "y")
- | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) ->
- let id = match lna.(i) with Name id -> id | _ -> assert false in
- lowercase_first_char id
- | Evar _ (* We could do better... *)
- | Meta _ | Case (_, _, _, _) -> "y"
- in
- hdrec 0 c
-
-let id_of_name_using_hdchar env a = function
- | Anonymous -> Id.of_string (hdchar env a)
- | Name id -> id
-
-let named_hd env a = function
- | Anonymous -> Name (Id.of_string (hdchar env a))
- | x -> x
-
-let mkProd_name env (n,a,b) = mkProd (named_hd env a n, a, b)
-let mkLambda_name env (n,a,b) = mkLambda (named_hd env a n, a, b)
-
-let lambda_name = mkLambda_name
-let prod_name = mkProd_name
-
-let prod_create env (a,b) = mkProd (named_hd env a Anonymous, a, b)
-let lambda_create env (a,b) = mkLambda (named_hd env a Anonymous, a, b)
-
-let name_assumption env (na,c,t) =
- match c with
- | None -> (named_hd env t na, None, t)
- | Some body -> (named_hd env body na, c, t)
-
-let name_context env hyps =
- snd
- (List.fold_left
- (fun (env,hyps) d ->
- let d' = name_assumption env d in (push_rel d' env, d' :: hyps))
- (env,[]) (List.rev hyps))
-
-let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b
-let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b
-
-let it_mkProd_or_LetIn_name env b hyps =
- it_mkProd_or_LetIn b (name_context env hyps)
-let it_mkLambda_or_LetIn_name env b hyps =
- it_mkLambda_or_LetIn b (name_context env hyps)
-
-(**********************************************************************)
-(* Fresh names *)
-
-(* Looks for next "good" name by lifting subscript *)
-
-let next_ident_away_from id bad =
- let rec name_rec id = if bad id then name_rec (lift_subscript id) else id in
- name_rec id
-
-(* Restart subscript from x0 if name starts with xN, or x00 if name
- starts with x0N, etc *)
-
-let restart_subscript id =
- if not (has_subscript id) then id else
- (* It would probably be better with something in the spirit of
- *** make_ident id (Some 0) *** but compatibility would be lost... *)
- forget_subscript id
-
-let rec to_avoid id = function
-| [] -> false
-| id' :: avoid -> Id.equal id id' || to_avoid id avoid
-
-let occur_rel p env id =
- try
- let name = lookup_name_of_rel p env in
- begin match name with
- | Name id' -> Id.equal id' id
- | Anonymous -> false
- end
- with Not_found -> false (* Unbound indice : may happen in debug *)
-
-let visibly_occur_id id (nenv,c) =
- let rec occur n c = match kind_of_term c with
- | Const _ | Ind _ | Construct _ | Var _
- when
- let short = shortest_qualid_of_global Id.Set.empty (global_of_constr c) in
- qualid_eq short (qualid_of_ident id) ->
- raise Occur
- | Rel p when p>n && occur_rel (p-n) nenv id -> raise Occur
- | _ -> iter_constr_with_binders succ occur n c
- in
- try occur 1 c; false
- with Occur -> true
- | Not_found -> false (* Happens when a global is not in the env *)
-
-(* Now, there are different renaming strategies... *)
-
-(* 1- Looks for a fresh name for printing in cases pattern *)
-
-let next_name_away_in_cases_pattern env_t na avoid =
- let id = match na with Name id -> id | Anonymous -> default_dependent_ident in
- let bad id = to_avoid id avoid || is_constructor id
- || visibly_occur_id id env_t in
- next_ident_away_from id bad
-
-(* 2- Looks for a fresh name for introduction in goal *)
-
-(* The legacy strategy for renaming introduction variables is not very uniform:
- - if the name to use is fresh in the context but used as a global
- name, then a fresh name is taken by finding a free subscript
- starting from the current subscript;
- - but if the name to use is not fresh in the current context, the fresh
- name is taken by finding a free subscript starting from 0 *)
-
-let next_ident_away_in_goal id avoid =
- let id = if to_avoid id avoid then restart_subscript id else id in
- let bad id = to_avoid id avoid || (is_global id && not (is_section_variable id)) in
- next_ident_away_from id bad
-
-let next_name_away_in_goal na avoid =
- let id = match na with
- | Name id -> id
- | Anonymous -> default_non_dependent_ident in
- next_ident_away_in_goal id avoid
-
-(* 3- Looks for next fresh name outside a list that is moreover valid
- as a global identifier; the legacy algorithm is that if the name is
- already used in the list, one looks for a name of same base with
- lower available subscript; if the name is not in the list but is
- used globally, one looks for a name of same base with lower subscript
- beyond the current subscript *)
-
-let next_global_ident_away id avoid =
- let id = if to_avoid id avoid then restart_subscript id else id in
- let bad id = to_avoid id avoid || is_global id in
- next_ident_away_from id bad
-
-(* 4- Looks for next fresh name outside a list; if name already used,
- looks for same name with lower available subscript *)
-
-let next_ident_away id avoid =
- if to_avoid id avoid then
- next_ident_away_from (restart_subscript id) (fun id -> to_avoid id avoid)
- else id
-
-let next_name_away_with_default default na avoid =
- let id = match na with Name id -> id | Anonymous -> Id.of_string default in
- next_ident_away id avoid
-
-let reserved_type_name = ref (fun t -> Anonymous)
-let set_reserved_typed_name f = reserved_type_name := f
-
-let next_name_away_with_default_using_types default na avoid t =
- let id = match na with
- | Name id -> id
- | Anonymous -> match !reserved_type_name t with
- | Name id -> id
- | Anonymous -> Id.of_string default in
- next_ident_away id avoid
-
-let next_name_away = next_name_away_with_default default_non_dependent_string
-
-let make_all_name_different env =
- let avoid = ref (ids_of_named_context (named_context env)) in
- process_rel_context
- (fun (na,c,t) newenv ->
- let na = named_hd newenv t na in
- let id = next_name_away na !avoid in
- avoid := id::!avoid;
- push_rel (Name id,c,t) newenv)
- env
-
-(* 5- Looks for next fresh name outside a list; avoids also to use names that
- would clash with short name of global references; if name is already used,
- looks for name of same base with lower available subscript beyond current
- subscript *)
-
-let next_ident_away_for_default_printing env_t id avoid =
- let bad id = to_avoid id avoid || visibly_occur_id id env_t in
- next_ident_away_from id bad
-
-let next_name_away_for_default_printing env_t na avoid =
- let id = match na with
- | Name id -> id
- | Anonymous ->
- (* In principle, an anonymous name is not dependent and will not be *)
- (* taken into account by the function compute_displayed_name_in; *)
- (* just in case, invent a valid name *)
- default_non_dependent_ident in
- next_ident_away_for_default_printing env_t id avoid
-
-(**********************************************************************)
-(* Displaying terms avoiding bound variables clashes *)
-
-(* Renaming strategy introduced in December 1998:
-
- - Rule number 1: all names, even if unbound and not displayed, contribute
- to the list of names to avoid
- - Rule number 2: only the dependency status is used for deciding if
- a name is displayed or not
-
- Example:
- bool_ind: "forall (P:bool->Prop)(f:(P true))(f:(P false))(b:bool), P b" is
- displayed "forall P:bool->Prop, P true -> P false -> forall b:bool, P b"
- but f and f0 contribute to the list of variables to avoid (knowing
- that f and f0 are how the f's would be named if introduced, assuming
- no other f and f0 are already used).
-*)
-
-type renaming_flags =
- | RenamingForCasesPattern of (Name.t list * constr)
- | RenamingForGoal
- | RenamingElsewhereFor of (Name.t list * constr)
-
-let next_name_for_display flags =
- match flags with
- | RenamingForCasesPattern env_t -> next_name_away_in_cases_pattern env_t
- | RenamingForGoal -> next_name_away_in_goal
- | RenamingElsewhereFor env_t -> next_name_away_for_default_printing env_t
-
-(* Remark: Anonymous var may be dependent in Evar's contexts *)
-let compute_displayed_name_in flags avoid na c =
- match na with
- | Anonymous when noccurn 1 c ->
- (Anonymous,avoid)
- | _ ->
- let fresh_id = next_name_for_display flags na avoid in
- let idopt = if noccurn 1 c then Anonymous else Name fresh_id in
- (idopt, fresh_id::avoid)
-
-let compute_and_force_displayed_name_in flags avoid na c =
- match na with
- | Anonymous when noccurn 1 c ->
- (Anonymous,avoid)
- | _ ->
- let fresh_id = next_name_for_display flags na avoid in
- (Name fresh_id, fresh_id::avoid)
-
-let compute_displayed_let_name_in flags avoid na c =
- let fresh_id = next_name_for_display flags na avoid in
- (Name fresh_id, fresh_id::avoid)
-
-let rename_bound_vars_as_displayed avoid env c =
- let rec rename avoid env c =
- match kind_of_term c with
- | Prod (na,c1,c2) ->
- let na',avoid' =
- compute_displayed_name_in
- (RenamingElsewhereFor (env,c2)) avoid na c2 in
- mkProd (na', c1, rename avoid' (add_name na' env) c2)
- | LetIn (na,c1,t,c2) ->
- let na',avoid' =
- compute_displayed_let_name_in
- (RenamingElsewhereFor (env,c2)) avoid na c2 in
- mkLetIn (na',c1,t, rename avoid' (add_name na' env) c2)
- | Cast (c,k,t) -> mkCast (rename avoid env c, k,t)
- | _ -> c
- in
- rename avoid env c
-
-(**********************************************************************)
-(* "H"-based naming strategy introduced June 2014 for hypotheses in
- Prop produced by case/elim/destruct/induction, in place of the
- strategy that was using the first letter of the type, leading to
- inelegant "n:~A", "e:t=u", etc. when eliminating sumbool or similar
- types *)
-
-let h_based_elimination_names = ref false
-
-let use_h_based_elimination_names () =
- !h_based_elimination_names && Flags.version_strictly_greater Flags.V8_4
-
-open Goptions
-
-let _ = declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "use of \"H\"-based proposition names in elimination tactics";
- optkey = ["Standard";"Proposition";"Elimination";"Names"];
- optread = (fun () -> !h_based_elimination_names);
- optwrite = (:=) h_based_elimination_names }
diff --git a/pretyping/namegen.mli b/pretyping/namegen.mli
deleted file mode 100644
index 6751bd3c..00000000
--- a/pretyping/namegen.mli
+++ /dev/null
@@ -1,102 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open Term
-open Context
-open Environ
-
-(*********************************************************************
- Conventional default names *)
-
-val default_prop_ident : Id.t (* "H" *)
-val default_small_ident : Id.t (* "H" *)
-val default_type_ident : Id.t (* "X" *)
-val default_non_dependent_ident : Id.t (* "H" *)
-val default_dependent_ident : Id.t (* "x" *)
-
-(*********************************************************************
- Generating "intuitive" names from their type *)
-
-val lowercase_first_char : Id.t -> string
-val sort_hdchar : sorts -> string
-val hdchar : env -> types -> string
-val id_of_name_using_hdchar : env -> types -> Name.t -> Id.t
-val named_hd : env -> types -> Name.t -> Name.t
-val head_name : types -> Id.t option
-
-val mkProd_name : env -> Name.t * types * types -> types
-val mkLambda_name : env -> Name.t * types * constr -> constr
-
-(** Deprecated synonyms of [mkProd_name] and [mkLambda_name] *)
-val prod_name : env -> Name.t * types * types -> types
-val lambda_name : env -> Name.t * types * constr -> constr
-
-val prod_create : env -> types * types -> constr
-val lambda_create : env -> types * constr -> constr
-val name_assumption : env -> rel_declaration -> rel_declaration
-val name_context : env -> rel_context -> rel_context
-
-val mkProd_or_LetIn_name : env -> types -> rel_declaration -> types
-val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr
-val it_mkProd_or_LetIn_name : env -> types -> rel_context -> types
-val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr
-
-(*********************************************************************
- Fresh names *)
-
-(** Avoid clashing with a name satisfying some predicate *)
-val next_ident_away_from : Id.t -> (Id.t -> bool) -> Id.t
-
-(** Avoid clashing with a name of the given list *)
-val next_ident_away : Id.t -> Id.t list -> Id.t
-
-(** Avoid clashing with a name already used in current module *)
-val next_ident_away_in_goal : Id.t -> Id.t list -> Id.t
-
-(** Avoid clashing with a name already used in current module
- but tolerate overwriting section variables, as in goals *)
-val next_global_ident_away : Id.t -> Id.t list -> Id.t
-
-(** Avoid clashing with a constructor name already used in current module *)
-val next_name_away_in_cases_pattern : (Termops.names_context * constr) -> Name.t -> Id.t list -> Id.t
-
-(** Default is [default_non_dependent_ident] *)
-val next_name_away : Name.t -> Id.t list -> Id.t
-
-val next_name_away_with_default : string -> Name.t -> Id.t list ->
- Id.t
-
-val next_name_away_with_default_using_types : string -> Name.t ->
- Id.t list -> types -> Id.t
-
-val set_reserved_typed_name : (types -> Name.t) -> unit
-
-(*********************************************************************
- Making name distinct for displaying *)
-
-type renaming_flags =
- | RenamingForCasesPattern of (Name.t list * constr) (** avoid only global constructors *)
- | RenamingForGoal (** avoid all globals (as in intro) *)
- | RenamingElsewhereFor of (Name.t list * constr)
-
-val make_all_name_different : env -> env
-
-val compute_displayed_name_in :
- renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
-val compute_and_force_displayed_name_in :
- renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
-val compute_displayed_let_name_in :
- renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
-val rename_bound_vars_as_displayed :
- Id.t list -> Name.t list -> types -> types
-
-(**********************************************************************)
-(* Naming strategy for arguments in Prop when eliminating inductive types *)
-
-val use_h_based_elimination_names : unit -> bool
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index 6d09d569..0dd64697 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Term
open Vars
open Environ
@@ -18,7 +18,7 @@ open Inductive
open Util
open Nativecode
open Nativevalues
-open Nativelambda
+open Context.Rel.Declaration
(** This module implements normalization by evaluation to OCaml code *)
@@ -35,13 +35,13 @@ let invert_tag cst tag reloc_tbl =
with Find_at j -> (j+1)
let decompose_prod env t =
- let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
+ let (name,dom,codom as res) = destProd (whd_all env t) in
match name with
| Anonymous -> (Name (id_of_string "x"),dom,codom)
| _ -> res
let app_type env c =
- let t = whd_betadeltaiota env c in
+ let t = whd_all env c in
try destApp t with DestKO -> (t,[||])
@@ -121,9 +121,8 @@ let build_case_type dep p realargs c =
else mkApp(p, realargs)
(* TODO move this function *)
-let type_of_rel env n =
- let (_,_,ty) = lookup_rel n env in
- lift n ty
+let type_of_rel env n =
+ lookup_rel n env |> get_type |> lift n
let type_of_prop = mkSort type1_sort
@@ -132,8 +131,9 @@ let type_of_sort s =
| Prop _ -> type_of_prop
| Type u -> mkType (Univ.super u)
-let type_of_var env id =
- try let (_,_,ty) = lookup_named id env in ty
+let type_of_var env id =
+ let open Context.Named.Declaration in
+ try lookup_named id env |> get_type
with Not_found ->
anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound")
@@ -178,10 +178,10 @@ let rec nf_val env v typ =
let name,dom,codom =
try decompose_prod env typ
with DestKO ->
- Errors.anomaly
+ CErrors.anomaly
(Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
in
- let env = push_rel (name,None,dom) env in
+ let env = push_rel (LocalAssum (name,dom)) env in
let body = nf_val env (f (mk_rel_accu lvl)) codom in
mkLambda(name,dom,body)
| Vconst n -> construct_of_constr_const env n typ
@@ -224,7 +224,7 @@ and nf_args env accu t =
let _,dom,codom =
try decompose_prod env t with
DestKO ->
- Errors.anomaly
+ CErrors.anomaly
(Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
in
let c = nf_val env arg dom in
@@ -241,7 +241,7 @@ and nf_bargs env b t =
let _,dom,codom =
try decompose_prod env !t with
DestKO ->
- Errors.anomaly
+ CErrors.anomaly
(Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
in
let c = nf_val env (block_field b i) dom in
@@ -257,7 +257,7 @@ and nf_atom env atom =
| Aprod(n,dom,codom) ->
let dom = nf_type env dom in
let vn = mk_rel_accu (nb_rel env) in
- let env = push_rel (n,None,dom) env in
+ let env = push_rel (LocalAssum (n,dom)) env in
let codom = nf_type env (codom vn) in
mkProd(n,dom,codom)
| Ameta (mv,_) -> mkMeta mv
@@ -289,7 +289,7 @@ and nf_atom_type env atom =
let pT =
hnf_prod_applist env
(Inductiveops.type_of_inductive env ind) (Array.to_list params) in
- let pT = whd_betadeltaiota env pT in
+ let pT = whd_all env pT in
let dep, p = nf_predicate env ind mip params p pT in
(* Calcul du type des branches *)
let btypes = build_branches_type env (fst ind) mib mip u params dep p in
@@ -328,7 +328,7 @@ and nf_atom_type env atom =
| Aprod(n,dom,codom) ->
let dom,s1 = nf_type_sort env dom in
let vn = mk_rel_accu (nb_rel env) in
- let env = push_rel (n,None,dom) env in
+ let env = push_rel (LocalAssum (n,dom)) env in
let codom,s2 = nf_type_sort env (codom vn) in
mkProd(n,dom,codom), mkSort (sort_of_product env s1 s2)
| Aevar(ev,ty) ->
@@ -352,11 +352,11 @@ and nf_predicate env ind mip params v pT =
let name,dom,codom =
try decompose_prod env pT with
DestKO ->
- Errors.anomaly
+ CErrors.anomaly
(Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
in
let dep,body =
- nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
+ nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in
dep, mkLambda(name,dom,body)
| Vfun f, _ ->
let k = nb_rel env in
@@ -366,7 +366,7 @@ and nf_predicate env ind mip params v pT =
let rargs = Array.init n (fun i -> mkRel (n-i)) in
let params = if Int.equal n 0 then params else Array.map (lift n) params in
let dom = mkApp(mkIndU ind,Array.append params rargs) in
- let body = nf_type (push_rel (name,None,dom) env) vb in
+ let body = nf_type (push_rel (LocalAssum (name,dom)) env) vb in
true, mkLambda(name,dom,body)
| _, _ -> false, nf_type env v
@@ -389,16 +389,16 @@ let native_norm env sigma c ty =
let code, upd = mk_norm_code penv sigma prefix c in
match Nativelib.compile ml_filename code with
| true, fn ->
- if !Flags.debug then Pp.msg_debug (Pp.str "Running norm ...");
+ if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ...");
let t0 = Sys.time () in
Nativelib.call_linker ~fatal:true prefix fn (Some upd);
let t1 = Sys.time () in
let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in
- if !Flags.debug then Pp.msg_debug (Pp.str time_info);
+ if !Flags.debug then Feedback.msg_debug (Pp.str time_info);
let res = nf_val env !Nativelib.rt1 ty in
let t2 = Sys.time () in
let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in
- if !Flags.debug then Pp.msg_debug (Pp.str time_info);
+ if !Flags.debug then Feedback.msg_debug (Pp.str time_info);
res
| _ -> anomaly (Pp.str "Compilation failure")
diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli
index bbda55f4..0b1ce8e5 100644
--- a/pretyping/nativenorm.mli
+++ b/pretyping/nativenorm.mli
@@ -8,7 +8,6 @@
open Term
open Environ
open Evd
-open Nativelambda
(** This module implements normalization by evaluation to OCaml code *)
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index af46c390..fe73b610 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Globnames
@@ -123,6 +123,7 @@ let head_of_constr_reference c = match kind_of_term c with
let pattern_of_constr env sigma t =
let rec pattern_of_constr env t =
+ let open Context.Rel.Declaration in
match kind_of_term t with
| Rel n -> PRel n
| Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n)))
@@ -132,11 +133,11 @@ let pattern_of_constr env sigma t =
| Sort (Type _) -> PSort (GType [])
| Cast (c,_,_) -> pattern_of_constr env c
| LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c,
- pattern_of_constr (push_rel (na,Some c,t) env) b)
+ pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b)
| Prod (na,c,b) -> PProd (na,pattern_of_constr env c,
- pattern_of_constr (push_rel (na, None, c) env) b)
+ pattern_of_constr (push_rel (LocalAssum (na, c)) env) b)
| Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c,
- pattern_of_constr (push_rel (na, None, c) env) b)
+ pattern_of_constr (push_rel (LocalAssum (na, c)) env) b)
| App (f,a) ->
(match
match kind_of_term f with
@@ -316,6 +317,10 @@ let rev_it_mkPLambda = List.fold_right mkPLambda
let err loc pp = user_err_loc (loc,"pattern_of_glob_constr", pp)
+let warn_cast_in_pattern =
+ CWarnings.create ~name:"cast-in-pattern" ~category:"automation"
+ (fun () -> Pp.strbrk "Casts are ignored in patterns")
+
let rec pat_of_raw metas vars = function
| GVar (_,id) ->
(try PRel (List.index Name.equal (Name id) vars)
@@ -347,7 +352,7 @@ let rec pat_of_raw metas vars = function
| GHole _ ->
PMeta None
| GCast (_,c,_) ->
- Pp.msg_warning (strbrk "Cast not taken into account in constr pattern");
+ warn_cast_in_pattern ();
pat_of_raw metas vars c
| GIf (_,c,(_,None),b1,b2) ->
PIf (pat_of_raw metas vars c,
diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli
index 5f877814..1f63565d 100644
--- a/pretyping/patternops.mli
+++ b/pretyping/patternops.mli
@@ -6,7 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Context
open Term
open Globnames
open Glob_term
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index cf5b08c5..00b6100c 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -14,15 +14,16 @@ open Type_errors
type unification_error =
| OccurCheck of existential_key * constr
- | NotClean of existential * env * constr
+ | NotClean of existential * env * constr (* Constr is a variable not in scope *)
| NotSameArgSize
| NotSameHead
| NoCanonicalStructure
- | ConversionFailed of env * constr * constr
+ | ConversionFailed of env * constr * constr (* Non convertible closed terms *)
| MetaOccurInBody of existential_key
| InstanceNotSameType of existential_key * env * types * types
| UnifUnivInconsistency of Univ.univ_inconsistency
| CannotSolveConstraint of Evd.evar_constraint * unification_error
+ | ProblemBeyondCapabilities
type position = (Id.t * Locus.hyp_location_flag) option
@@ -59,7 +60,7 @@ type pretype_error =
exception PretypeError of env * Evd.evar_map * pretype_error
let precatchable_exception = function
- | Errors.UserError _ | TypeError _ | PretypeError _
+ | CErrors.UserError _ | TypeError _ | PretypeError _
| Nametab.GlobalizationError _ -> true
| _ -> false
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index f617df9e..880f48e5 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -24,6 +24,7 @@ type unification_error =
| InstanceNotSameType of existential_key * env * types * types
| UnifUnivInconsistency of Univ.univ_inconsistency
| CannotSolveConstraint of Evd.evar_constraint * unification_error
+ | ProblemBeyondCapabilities
type position = (Id.t * Locus.hyp_location_flag) option
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index ac0104d9..4b6d10c6 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -22,13 +22,12 @@
open Pp
-open Errors
+open CErrors
open Util
open Names
open Evd
open Term
open Vars
-open Context
open Termops
open Reductionops
open Environ
@@ -37,17 +36,20 @@ open Typeops
open Globnames
open Nameops
open Evarutil
+open Evardefine
open Pretype_errors
open Glob_term
open Glob_ops
open Evarconv
open Pattern
open Misctypes
+open Sigma.Notations
+open Context.Named.Declaration
type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
type var_map = constr_under_binders Id.Map.t
type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t
-type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t
+type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t
type ltac_var_map = {
ltac_constrs : var_map;
ltac_uconstrs : uconstr_var_map;
@@ -56,6 +58,8 @@ type ltac_var_map = {
}
type glob_constr_ltac_closure = ltac_var_map * glob_constr
type pure_open_constr = evar_map * constr
+type 'a delayed_open =
+ { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
(************************************************************************)
(* This concerns Cases *)
@@ -64,6 +68,61 @@ open Inductiveops
(************************************************************************)
+module ExtraEnv =
+struct
+
+type t = {
+ env : Environ.env;
+ extra : Evarutil.ext_named_context Lazy.t;
+ (** Delay the computation of the evar extended environment *)
+}
+
+let get_extra env =
+ let open Context.Named.Declaration in
+ let ids = List.map get_id (named_context env) in
+ let avoid = List.fold_right Id.Set.add ids Id.Set.empty in
+ Context.Rel.fold_outside push_rel_decl_to_named_context
+ (Environ.rel_context env) ~init:(empty_csubst, [], avoid, named_context env)
+
+let make_env env = { env = env; extra = lazy (get_extra env) }
+let rel_context env = rel_context env.env
+
+let push_rel d env = {
+ env = push_rel d env.env;
+ extra = lazy (push_rel_decl_to_named_context d (Lazy.force env.extra));
+}
+
+let pop_rel_context n env = make_env (pop_rel_context n env.env)
+
+let push_rel_context ctx env = {
+ env = push_rel_context ctx env.env;
+ extra = lazy (List.fold_right push_rel_decl_to_named_context ctx (Lazy.force env.extra));
+}
+
+let lookup_named id env = lookup_named id env.env
+
+let e_new_evar env evdref ?src ?naming typ =
+ let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) in
+ let open Context.Named.Declaration in
+ let inst_vars = List.map (fun d -> mkVar (get_id d)) (named_context env.env) in
+ let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in
+ let (subst, vsubst, _, nc) = Lazy.force env.extra in
+ let typ' = subst2 subst vsubst typ in
+ let instance = inst_rels @ inst_vars in
+ let sign = val_of_named_context nc in
+ let sigma = Sigma.Unsafe.of_evar_map !evdref in
+ let Sigma (e, sigma, _) = new_evar_instance sign sigma typ' ?src ?naming instance in
+ evdref := Sigma.to_evar_map sigma;
+ e
+
+let push_rec_types (lna,typarray,_) env =
+ let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in
+ Array.fold_left (fun e assum -> push_rel assum e) env ctxt
+
+end
+
+open ExtraEnv
+
(* An auxiliary function for searching for fixpoint guard indexes *)
exception Found of int array
@@ -77,7 +136,7 @@ let search_guard loc env possible_indexes fixdefs =
let fix = ((indexes, 0),fixdefs) in
(try check_fix env fix
with reraise ->
- let (e, info) = Errors.push reraise in
+ let (e, info) = CErrors.push reraise in
let info = Loc.add_loc info loc in
iraise (e, info));
indexes
@@ -87,18 +146,23 @@ let search_guard loc env possible_indexes fixdefs =
List.iter
(fun l ->
let indexes = Array.of_list l in
- let fix = ((indexes, 0),fixdefs) in
- try check_fix env fix; raise (Found indexes)
+ let fix = ((indexes, 0),fixdefs) in
+ (* spiwack: We search for a unspecified structural
+ argument under the assumption that we need to check the
+ guardedness condition (otherwise the first inductive argument
+ will be chosen). A more robust solution may be to raise an
+ error when totality is assumed but the strutural argument is
+ not specified. *)
+ try
+ let flags = { (typing_flags env) with Declarations.check_guarded = true } in
+ let env = Environ.set_typing_flags flags env in
+ check_fix env fix; raise (Found indexes)
with TypeError _ -> ())
(List.combinations possible_indexes);
let errmsg = "Cannot guess decreasing argument of fix." in
user_err_loc (loc,"search_guard", Pp.str errmsg)
with Found indexes -> indexes)
-(* To embed constr in glob_constr *)
-let ((constr_in : constr -> Dyn.t),
- (constr_out : Dyn.t -> constr)) = Dyn.create "constr"
-
(* To force universe name declaration before use *)
let strict_universe_declarations = ref true
@@ -134,24 +198,24 @@ let interp_universe_level_name evd (loc,s) =
let level = Univ.Level.make dp num in
let evd =
try Evd.add_global_univ evd level
- with Univ.AlreadyDeclared -> evd
+ with UGraph.AlreadyDeclared -> evd
in evd, level
else
try
- let id =
- try Id.of_string s with _ -> raise Not_found in
- evd, Idmap.find id names
+ let level = Evd.universe_of_name evd s in
+ evd, level
with Not_found ->
- try let level = Evd.universe_of_name evd s in
- evd, level
+ try
+ let id = try Id.of_string s with _ -> raise Not_found in
+ evd, snd (Idmap.find id names)
with Not_found ->
if not (is_strict_universe_declarations ()) then
- new_univ_level_variable ~name:s univ_rigid evd
+ new_univ_level_variable ~loc ~name:s univ_rigid evd
else user_err_loc (loc, "interp_universe_level_name",
Pp.(str "Undeclared universe: " ++ str s))
-let interp_universe evd = function
- | [] -> let evd, l = new_univ_level_variable univ_rigid evd in
+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 ->
@@ -159,15 +223,15 @@ let interp_universe evd = function
(evd', Univ.sup u (Univ.Universe.make l)))
(evd, Univ.Universe.type0m) l
-let interp_universe_level evd = function
- | None -> new_univ_level_variable univ_rigid evd
+let interp_universe_level loc evd = function
+ | None -> new_univ_level_variable ~loc univ_rigid evd
| Some (loc,s) -> interp_universe_level_name evd (loc,s)
-let interp_sort evd = function
+let interp_sort ?loc evd = function
| GProp -> evd, Prop Null
| GSet -> evd, Prop Pos
| GType n ->
- let evd, u = interp_universe evd n in
+ let evd, u = interp_universe ?loc evd n in
evd, Type u
let interp_elimination_sort = function
@@ -175,23 +239,31 @@ let interp_elimination_sort = function
| GSet -> InSet
| GType _ -> InType
+type inference_hook = env -> evar_map -> evar -> evar_map * constr
+
type inference_flags = {
use_typeclasses : bool;
- use_unif_heuristics : bool;
- use_hook : (env -> evar_map -> evar -> constr) option;
+ solve_unification_constraints : bool;
+ use_hook : inference_hook option;
fail_evar : bool;
expand_evars : bool
}
-let frozen_holes (sigma, sigma') =
- let fold evk _ accu = Evar.Set.add evk accu in
- Evd.fold_undefined fold sigma Evar.Set.empty
-
-let pending_holes (sigma, sigma') =
- let fold evk _ accu =
- if not (Evd.mem sigma evk) then Evar.Set.add evk accu else accu
- in
- Evd.fold_undefined fold sigma' Evar.Set.empty
+(* Compute the set of still-undefined initial evars up to restriction
+ (e.g. clearing) and the set of yet-unsolved evars freshly created
+ in the extension [sigma'] of [sigma] (excluding the restrictions of
+ the undefined evars of [sigma] to be freshly created evars of
+ [sigma']). Otherwise said, we partition the undefined evars of
+ [sigma'] into those already in [sigma] or deriving from an evar in
+ [sigma] by restriction, and the evars properly created in [sigma'] *)
+
+let frozen_and_pending_holes (sigma, sigma') =
+ let add_derivative_of evk evi acc =
+ match advance sigma' evk with None -> acc | Some evk' -> Evar.Set.add evk' acc in
+ let frozen = Evd.fold_undefined add_derivative_of sigma Evar.Set.empty in
+ let fold evk _ accu = if not (Evar.Set.mem evk frozen) then Evar.Set.add evk accu else accu in
+ let pending = Evd.fold_undefined fold sigma' Evar.Set.empty in
+ (frozen,pending)
let apply_typeclasses env evdref frozen fail_evar =
let filter_frozen evk = Evar.Set.mem evk frozen in
@@ -209,7 +281,7 @@ let apply_inference_hook hook evdref pending =
if Evd.is_undefined sigma evk (* in particular not defined by side-effect *)
then
try
- let c = hook sigma evk in
+ let sigma, c = hook sigma evk in
Evd.define evk c sigma
with Exit ->
sigma
@@ -218,10 +290,10 @@ let apply_inference_hook hook evdref pending =
let apply_heuristics env evdref fail_evar =
(* Resolve eagerly, potentially making wrong choices *)
- try evdref := consider_remaining_unif_problems
+ try evdref := solve_unif_constraints_with_heuristics
~ts:(Typeclasses.classes_transparent_state ()) env !evdref
- with e when Errors.noncritical e ->
- let e = Errors.push e in if fail_evar then iraise e
+ with e when CErrors.noncritical e ->
+ let e = CErrors.push e in if fail_evar then iraise e
let check_typeclasses_instances_are_solved env current_sigma frozen =
(* Naive way, call resolution again with failure flag *)
@@ -237,6 +309,23 @@ let check_extra_evars_are_solved env current_sigma pending =
| _ ->
error_unsolvable_implicit loc env current_sigma evk None) pending
+(* [check_evars] fails if some unresolved evar remains *)
+
+let check_evars env initial_sigma sigma c =
+ let rec proc_rec c =
+ match kind_of_term c with
+ | Evar (evk,_ as ev) ->
+ (match existential_opt_value sigma ev with
+ | Some c -> proc_rec c
+ | None ->
+ if not (Evd.mem initial_sigma evk) then
+ let (loc,k) = evar_source evk sigma in
+ match k with
+ | Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
+ | _ -> Pretype_errors.error_unsolvable_implicit loc env sigma evk None)
+ | _ -> Constr.iter proc_rec c
+ in proc_rec c
+
let check_evars_are_solved env current_sigma frozen pending =
check_typeclasses_instances_are_solved env current_sigma frozen;
check_problems_are_solved env current_sigma;
@@ -245,19 +334,17 @@ let check_evars_are_solved env current_sigma frozen pending =
(* Try typeclasses, hooks, unification heuristics ... *)
let solve_remaining_evars flags env current_sigma pending =
- let frozen = frozen_holes pending in
- let pending = pending_holes pending in
+ let frozen,pending = frozen_and_pending_holes pending in
let evdref = ref current_sigma in
if flags.use_typeclasses then apply_typeclasses env evdref frozen false;
if Option.has_some flags.use_hook then
apply_inference_hook (Option.get flags.use_hook env) evdref pending;
- if flags.use_unif_heuristics then apply_heuristics env evdref false;
+ if flags.solve_unification_constraints then apply_heuristics env evdref false;
if flags.fail_evar then check_evars_are_solved env !evdref frozen pending;
!evdref
let check_evars_are_solved env current_sigma pending =
- let frozen = frozen_holes pending in
- let pending = pending_holes pending in
+ let frozen,pending = frozen_and_pending_holes pending in
check_evars_are_solved env current_sigma frozen pending
let process_inference_flags flags env initial_sigma (sigma,c) =
@@ -268,26 +355,11 @@ let process_inference_flags flags env initial_sigma (sigma,c) =
(* Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *)
let allow_anonymous_refs = ref false
-(* Utilisé pour inférer le prédicat des Cases *)
-(* Semble exagérement fort *)
-(* Faudra préférer une unification entre les types de toutes les clauses *)
-(* et autoriser des ? à rester dans le résultat de l'unification *)
-
-let evar_type_fixpoint loc env evdref lna lar vdefj =
- let lt = Array.length vdefj in
- if Int.equal (Array.length lar) lt then
- for i = 0 to lt-1 do
- if not (e_cumul env evdref (vdefj.(i)).uj_type
- (lift lt lar.(i))) then
- error_ill_typed_rec_body_loc loc env !evdref
- i lna vdefj lar
- done
-
(* coerce to tycon if any *)
let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function
| None -> j
| Some t ->
- evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env) evdref j t
+ evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env.ExtraEnv.env) evdref j t
let check_instance loc subst = function
| [] -> ()
@@ -321,11 +393,12 @@ let ltac_interp_name_env k0 lvar env =
specification of pretype which accepts to start with a non empty
rel_context) *)
(* tail is the part of the env enriched by pretyping *)
- let n = rel_context_length (rel_context env) - k0 in
+ let n = Context.Rel.length (rel_context env) - k0 in
let ctxt,_ = List.chop n (rel_context env) in
- let env = pop_rel_context n env in
- let ctxt = List.map (fun (na,c,t) -> ltac_interp_name lvar na,c,t) ctxt in
- push_rel_context ctxt env
+ let open Context.Rel.Declaration in
+ let ctxt' = List.smartmap (map_name (ltac_interp_name lvar)) ctxt in
+ if List.equal (fun d1 d2 -> Name.equal (get_name d1) (get_name d2)) ctxt ctxt' then env
+ else push_rel_context ctxt' (pop_rel_context n env)
let invert_ltac_bound_name lvar env id0 id =
let id' = Id.Map.find id lvar.ltac_idents in
@@ -336,7 +409,7 @@ let invert_ltac_bound_name lvar env id0 id =
str " which is not bound in current context.")
let protected_get_type_of env sigma c =
- try Retyping.get_type_of ~lax:true env sigma c
+ try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c
with Retyping.RetypeError _ ->
errorlabstrm ""
(str "Cannot reinterpret " ++ quote (print_constr c) ++
@@ -372,13 +445,15 @@ let pretype_id pretype k0 loc env evdref lvar id =
with Not_found ->
(* Check if [id] is a ltac variable not bound to a term *)
(* and build a nice error message *)
- if Id.Map.mem id lvar.ltac_genargs then
+ if Id.Map.mem id lvar.ltac_genargs then begin
+ let Geninterp.Val.Dyn (typ, _) = Id.Map.find id lvar.ltac_genargs in
user_err_loc (loc,"",
- str "Variable " ++ pr_id id ++ str " should be bound to a term.");
+ str "Variable " ++ pr_id id ++ str " should be bound to a term but is \
+ bound to a " ++ Geninterp.Val.pr typ ++ str ".")
+ end;
(* Check if [id] is a section or goal variable *)
try
- let (_,_,typ) = lookup_named id env in
- { uj_val = mkVar id; uj_type = typ }
+ { uj_val = mkVar id; uj_type = (get_type (lookup_named id env)) }
with Not_found ->
(* [id] not found, standard error message *)
error_var_not_found_loc loc id
@@ -389,11 +464,11 @@ let evar_kind_of_term sigma c =
(*************************************************************************)
(* Main pretyping function *)
-let interp_universe_level_name evd l =
+let interp_universe_level_name loc evd l =
match l with
| GProp -> evd, Univ.Level.prop
| GSet -> evd, Univ.Level.set
- | GType s -> interp_universe_level evd s
+ | GType s -> interp_universe_level loc evd s
let pretype_global loc rigid env evd gr us =
let evd, instance =
@@ -408,7 +483,7 @@ let pretype_global loc rigid env evd gr us =
str "Universe instance should have length " ++ int len)
else
let evd, l' = List.fold_left (fun (evd, univs) l ->
- let evd, l = interp_universe_level_name evd l in
+ let evd, l = interp_universe_level_name loc evd l in
(evd, l :: univs)) (evd, []) l
in
if List.exists (fun l -> Univ.Level.is_prop l) l' then
@@ -417,14 +492,13 @@ let pretype_global loc rigid env evd gr us =
str " universe instances must be greater or equal to Set.");
evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l')))
in
- Evd.fresh_global ~rigid ?names:instance env evd gr
+ Evd.fresh_global ~loc ~rigid ?names:instance env.ExtraEnv.env evd gr
let pretype_ref loc evdref env ref us =
match ref with
| VarRef id ->
(* Section variable *)
- (try let (_,_,ty) = lookup_named id env in
- make_judge (mkVar id) ty
+ (try make_judge (mkVar id) (get_type (lookup_named id env))
with Not_found ->
(* This may happen if env is a goal env and section variables have
been cleared - section variables should be different from goal
@@ -433,34 +507,29 @@ let pretype_ref loc evdref env ref us =
| ref ->
let evd, c = pretype_global loc univ_flexible env !evdref ref us in
let () = evdref := evd in
- let ty = Typing.unsafe_type_of env evd c in
+ let ty = Typing.unsafe_type_of env.ExtraEnv.env evd c in
make_judge c ty
-let judge_of_Type evd s =
- let evd, s = interp_universe evd s in
+let judge_of_Type loc evd s =
+ let evd, s = interp_universe ~loc evd s in
let judge =
{ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }
in
evd, judge
-let pretype_sort evdref = function
+let pretype_sort loc evdref = function
| GProp -> judge_of_prop
| GSet -> judge_of_set
- | GType s -> evd_comb1 judge_of_Type evdref s
+ | GType s -> evd_comb1 (judge_of_Type loc) evdref s
let new_type_evar env evdref loc =
- let e, s =
- evd_comb0 (fun evd -> Evarutil.new_type_evar env evd
- univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref
- in e
-
-let get_projection env cst =
- let cb = lookup_constant cst env in
- match cb.Declarations.const_proj with
- | Some {Declarations.proj_ind = mind; proj_npars = n;
- proj_arg = m; proj_type = ty} ->
- (cst,mind,n,m,ty)
- | None -> raise Not_found
+ let sigma = Sigma.Unsafe.of_evar_map !evdref in
+ let Sigma ((e, _), sigma, _) =
+ Evarutil.new_type_evar env.ExtraEnv.env sigma
+ univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)
+ in
+ evdref := Sigma.to_evar_map sigma;
+ e
let (f_genarg_interp, genarg_interp_hook) = Hook.make ()
@@ -468,16 +537,11 @@ let (f_genarg_interp, genarg_interp_hook) = Hook.make ()
(* in environment [env], with existential variables [evdref] and *)
(* the type constraint tycon *)
-let is_GHole = function
- | GHole _ -> true
- | _ -> false
-
-let evars = ref Id.Map.empty
-
-let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var_map) t =
+let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdref (lvar : ltac_var_map) t =
let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in
let pretype_type = pretype_type k0 resolve_tc in
let pretype = pretype k0 resolve_tc in
+ let open Context.Rel.Declaration in
match t with
| GRef (loc,ref,u) ->
inh_conv_coerce_to_tycon loc env evdref
@@ -499,7 +563,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
let hyps = evar_filtered_context (Evd.find !evdref evk) in
let args = pretype_instance k0 resolve_tc env evdref lvar loc hyps evk inst in
let c = mkEvar (evk, args) in
- let j = (Retyping.get_judgment_of env !evdref c) in
+ let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref c) in
inh_conv_coerce_to_tycon loc env evdref j tycon
| GPatVar (loc,(someta,n)) ->
@@ -528,7 +592,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| None ->
new_type_evar env evdref loc in
let ist = lvar.ltac_genargs in
- let (c, sigma) = Hook.get f_genarg_interp ty env !evdref ist arg in
+ let (c, sigma) = Hook.get f_genarg_interp ty env.ExtraEnv.env !evdref ist arg in
let () = evdref := sigma in
{ uj_val = c; uj_type = ty }
@@ -537,16 +601,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
[] -> ctxt
| (na,bk,None,ty)::bl ->
let ty' = pretype_type empty_valcon env evdref lvar ty in
- let dcl = (na,None,ty'.utj_val) in
- let dcl' = (ltac_interp_name lvar na,None,ty'.utj_val) in
- type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl
+ let dcl = LocalAssum (na, ty'.utj_val) in
+ let dcl' = LocalAssum (ltac_interp_name lvar na,ty'.utj_val) in
+ type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl
| (na,bk,Some bd,ty)::bl ->
let ty' = pretype_type empty_valcon env evdref lvar ty in
let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in
- let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
- let dcl' = (ltac_interp_name lvar na,Some bd'.uj_val,ty'.utj_val) in
- type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl in
- let ctxtv = Array.map (type_bl env empty_rel_context) bl in
+ let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in
+ let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in
+ type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in
+ let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in
let larj =
Array.map2
(fun e ar ->
@@ -562,7 +626,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
let fixi = match fixkind with
| GFix (vn,i) -> i
| GCoFix i -> i
- in e_conv env evdref ftys.(fixi) t
+ in e_conv env.ExtraEnv.env evdref ftys.(fixi) t
| None -> true
in
(* Note: bodies are not used by push_rec_types, so [||] is safe *)
@@ -573,14 +637,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
(* we lift nbfix times the type in tycon, because of
* the nbfix variables pushed to newenv *)
let (ctxt,ty) =
- decompose_prod_n_assum (rel_context_length ctxt)
+ decompose_prod_n_assum (Context.Rel.length ctxt)
(lift nbfix ftys.(i)) in
let nenv = push_rel_context ctxt newenv in
let j = pretype (mk_tycon ty) nenv evdref lvar def in
{ uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
ctxtv vdef in
- evar_type_fixpoint loc env evdref names ftys vdefj;
+ Typing.check_type_fixpoint loc env.ExtraEnv.env evdref names ftys vdefj;
let ftys = Array.map (nf_evar !evdref) ftys in
let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in
let fixj = match fixkind with
@@ -599,13 +663,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
vn)
in
let fixdecls = (names,ftys,fdefs) in
- let indexes = search_guard loc env possible_indexes fixdecls in
+ let indexes =
+ search_guard
+ loc env.ExtraEnv.env possible_indexes fixdecls
+ in
make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
| GCoFix i ->
let cofix = (i,(names,ftys,fdefs)) in
- (try check_cofix env cofix
+ (try check_cofix env.ExtraEnv.env cofix
with reraise ->
- let (e, info) = Errors.push reraise in
+ let (e, info) = CErrors.push reraise in
let info = Loc.add_loc info loc in
iraise (e, info));
make_judge (mkCoFix cofix) ftys.(i)
@@ -613,7 +680,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
inh_conv_coerce_to_tycon loc env evdref fixj tycon
| GSort (loc,s) ->
- let j = pretype_sort evdref s in
+ let j = pretype_sort loc evdref s in
inh_conv_coerce_to_tycon loc env evdref j tycon
| GApp (loc,f,args) ->
@@ -633,7 +700,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
if Int.equal npars 0 then []
else
try
- let IndType (indf, args) = find_rectype env !evdref ty in
+ let IndType (indf, args) = find_rectype env.ExtraEnv.env !evdref ty in
let ((ind',u'),pars) = dest_ind_family indf in
if eq_ind ind ind' then pars
else (* Let the usual code throw an error *) []
@@ -642,9 +709,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
in
let app_f =
match kind_of_term fj.uj_val with
- | Const (p, u) when Environ.is_projection p env ->
+ | Const (p, u) when Environ.is_projection p env.ExtraEnv.env ->
let p = Projection.make p false in
- let pb = Environ.lookup_projection p env in
+ let pb = Environ.lookup_projection p env.ExtraEnv.env in
let npars = pb.Declarations.proj_npars in
fun n ->
if n == npars + 1 then fun _ v -> mkProj (p, v)
@@ -655,8 +722,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| [] -> resj
| c::rest ->
let argloc = loc_of_glob_constr c in
- let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in
- let resty = whd_betadeltaiota env !evdref resj.uj_type in
+ let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env.ExtraEnv.env) evdref resj in
+ let resty = whd_all env.ExtraEnv.env !evdref resj.uj_type in
match kind_of_term resty with
| Prod (na,c1,c2) ->
let tycon = Some c1 in
@@ -665,7 +732,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
match candargs with
| [] -> [], j_val hj
| arg :: args ->
- if e_conv env evdref (j_val hj) arg then
+ if e_conv env.ExtraEnv.env evdref (j_val hj) arg then
args, nf_evar !evdref (j_val hj)
else [], j_val hj
in
@@ -676,7 +743,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| _ ->
let hj = pretype empty_tycon env evdref lvar c in
error_cant_apply_not_functional_loc
- (Loc.merge floc argloc) env !evdref
+ (Loc.merge floc argloc) env.ExtraEnv.env !evdref
resj [hj]
in
let resj = apply_rec env 1 fj candargs args in
@@ -684,13 +751,13 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
match evar_kind_of_term !evdref resj.uj_val with
| App (f,args) ->
let f = whd_evar !evdref f in
- if is_template_polymorphic env f then
+ if is_template_polymorphic env.ExtraEnv.env f then
(* Special case for inductive type applications that must be
refreshed right away. *)
let sigma = !evdref in
let c = mkApp (f,Array.map (whd_evar sigma) args) in
- let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env) evdref c in
- let t = Retyping.get_type_of env !evdref c in
+ let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env.ExtraEnv.env) evdref c in
+ let t = Retyping.get_type_of env.ExtraEnv.env !evdref c in
make_judge c (* use this for keeping evars: resj.uj_val *) t
else resj
| _ -> resj
@@ -703,20 +770,20 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
match tycon with
| None -> evd, tycon
| Some ty ->
- let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in
+ let evd, ty' = Coercion.inh_coerce_to_prod loc env.ExtraEnv.env evd ty in
evd, Some ty')
evdref tycon
in
- let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in
+ let (name',dom,rng) = evd_comb1 (split_tycon loc env.ExtraEnv.env) evdref tycon' in
let dom_valcon = valcon_of_tycon dom in
let j = pretype_type dom_valcon env evdref lvar c1 in
(* The name specified by ltac is used also to create bindings. So
the substitution must also be applied on variables before they are
looked up in the rel context. *)
- let var = (name,None,j.utj_val) in
+ let var = LocalAssum (name, j.utj_val) in
let j' = pretype rng (push_rel var env) evdref lvar c2 in
let name = ltac_interp_name lvar name in
- let resj = judge_of_abstraction env (orelse_name name name') j j' in
+ let resj = judge_of_abstraction env.ExtraEnv.env (orelse_name name name') j j' in
inh_conv_coerce_to_tycon loc env evdref resj tycon
| GProd(loc,name,bk,c1,c2) ->
@@ -729,16 +796,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
let j = pretype_type empty_valcon env evdref lvar c2 in
{ j with utj_val = lift 1 j.utj_val }
| Name _ ->
- let var = (name,j.utj_val) in
- let env' = push_rel_assum var env in
+ let var = LocalAssum (name, j.utj_val) in
+ let env' = push_rel var env in
pretype_type empty_valcon env' evdref lvar c2
in
let name = ltac_interp_name lvar name in
let resj =
try
- judge_of_product env name j j'
+ judge_of_product env.ExtraEnv.env name j j'
with TypeError _ as e ->
- let (e, info) = Errors.push e in
+ let (e, info) = CErrors.push e in
let info = Loc.add_loc info loc in
iraise (e, info) in
inh_conv_coerce_to_tycon loc env evdref resj tycon
@@ -752,12 +819,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| _ -> pretype empty_tycon env evdref lvar c1
in
let t = evd_comb1 (Evarsolve.refresh_universes
- ~onlyalg:true ~status:Evd.univ_flexible (Some false) env)
+ ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env)
evdref j.uj_type in
(* The name specified by ltac is used also to create bindings. So
the substitution must also be applied on variables before they are
looked up in the rel context. *)
- let var = (name,Some j.uj_val,t) in
+ let var = LocalDef (name, j.uj_val, t) in
let tycon = lift_tycon 1 tycon in
let j' = pretype tycon (push_rel var env) evdref lvar c2 in
let name = ltac_interp_name lvar name in
@@ -767,12 +834,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| GLetTuple (loc,nal,(na,po),c,d) ->
let cj = pretype empty_tycon env evdref lvar c in
let (IndType (indf,realargs)) =
- try find_rectype env !evdref cj.uj_type
+ try find_rectype env.ExtraEnv.env !evdref cj.uj_type
with Not_found ->
let cloc = loc_of_glob_constr c in
- error_case_not_inductive_loc cloc env !evdref cj
+ error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj
in
- let cstrs = get_constructors env indf in
+ let cstrs = get_constructors env.ExtraEnv.env indf in
if not (Int.equal (Array.length cstrs) 1) then
user_err_loc (loc,"",str "Destructing let is only for inductive types" ++
str " with one constructor.");
@@ -781,18 +848,18 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
user_err_loc (loc,"", str "Destructing let on this type expects " ++
int cs.cs_nargs ++ str " variables.");
let fsign, record =
- match get_projections env indf with
- | None -> List.map2 (fun na (_,c,t) -> (na,c,t))
- (List.rev nal) cs.cs_args, false
+ match get_projections env.ExtraEnv.env indf with
+ | None ->
+ List.map2 set_name (List.rev nal) cs.cs_args, false
| Some ps ->
let rec aux n k names l =
match names, l with
- | na :: names, ((_, None, t) :: l) ->
+ | na :: names, (LocalAssum (_,t) :: l) ->
let proj = Projection.make ps.(cs.cs_nargs - k) true in
- (na, Some (lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val))), t)
+ LocalDef (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t)
:: aux (n+1) (k + 1) names l
- | na :: names, ((_, c, t) :: l) ->
- (na, c, t) :: aux (n+1) k names l
+ | na :: names, (decl :: l) ->
+ set_name na decl :: aux (n+1) k names l
| [], [] -> []
| _ -> assert false
in aux 1 1 (List.rev nal) cs.cs_args, true in
@@ -800,38 +867,38 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
if not record then
let nal = List.map (fun na -> ltac_interp_name lvar na) nal in
let nal = List.rev nal in
- let fsign = List.map2 (fun na (_,b,t) -> (na,b,t)) nal fsign in
+ let fsign = List.map2 set_name nal fsign in
let f = it_mkLambda_or_LetIn f fsign in
- let ci = make_case_info env (fst ind) LetStyle in
+ let ci = make_case_info env.ExtraEnv.env (fst ind) LetStyle in
mkCase (ci, p, cj.uj_val,[|f|])
else it_mkLambda_or_LetIn f fsign
in
let env_f = push_rel_context fsign env in
(* Make dependencies from arity signature impossible *)
let arsgn =
- let arsgn,_ = get_arity env indf in
+ let arsgn,_ = get_arity env.ExtraEnv.env indf in
if not !allow_anonymous_refs then
- List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+ List.map (set_name Anonymous) arsgn
else arsgn
in
- let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+ let psign = LocalAssum (na, build_dependent_inductive env.ExtraEnv.env indf) :: arsgn in
let nar = List.length arsgn in
(match po with
| Some p ->
let env_p = push_rel_context psign env in
let pj = pretype_type empty_valcon env_p evdref lvar p in
let ccl = nf_evar !evdref pj.utj_val in
- let psign = make_arity_signature env true indf in (* with names *)
+ let psign = make_arity_signature env.ExtraEnv.env true indf in (* with names *)
let p = it_mkLambda_or_LetIn ccl psign in
let inst =
(Array.to_list cs.cs_concl_realargs)
@[build_dependent_constructor cs] in
let lp = lift cs.cs_nargs p in
- let fty = hnf_lam_applist env !evdref lp inst in
+ let fty = hnf_lam_applist env.ExtraEnv.env !evdref lp inst in
let fj = pretype (mk_tycon fty) env_f evdref lvar d in
let v =
let ind,_ = dest_ind_family indf in
- Typing.check_allowed_sort env !evdref ind cj.uj_val p;
+ Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p;
obj ind p cj.uj_val fj.uj_val
in
{ uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
@@ -844,37 +911,37 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
if noccur_between 1 cs.cs_nargs ccl then
lift (- cs.cs_nargs) ccl
else
- error_cant_find_case_type_loc loc env !evdref
+ error_cant_find_case_type_loc loc env.ExtraEnv.env !evdref
cj.uj_val in
(* let ccl = refresh_universes ccl in *)
let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
let v =
let ind,_ = dest_ind_family indf in
- Typing.check_allowed_sort env !evdref ind cj.uj_val p;
+ Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p;
obj ind p cj.uj_val fj.uj_val
in { uj_val = v; uj_type = ccl })
| GIf (loc,c,(na,po),b1,b2) ->
let cj = pretype empty_tycon env evdref lvar c in
let (IndType (indf,realargs)) =
- try find_rectype env !evdref cj.uj_type
+ try find_rectype env.ExtraEnv.env !evdref cj.uj_type
with Not_found ->
let cloc = loc_of_glob_constr c in
- error_case_not_inductive_loc cloc env !evdref cj in
- let cstrs = get_constructors env indf in
+ error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj in
+ let cstrs = get_constructors env.ExtraEnv.env indf in
if not (Int.equal (Array.length cstrs) 2) then
user_err_loc (loc,"",
str "If is only for inductive types with two constructors.");
let arsgn =
- let arsgn,_ = get_arity env indf in
+ let arsgn,_ = get_arity env.ExtraEnv.env indf in
if not !allow_anonymous_refs then
(* Make dependencies from arity signature impossible *)
- List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+ List.map (set_name Anonymous) arsgn
else arsgn
in
let nar = List.length arsgn in
- let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+ let psign = LocalAssum (na, build_dependent_inductive env.ExtraEnv.env indf) :: arsgn in
let pred,p = match po with
| Some p ->
let env_p = push_rel_context psign env in
@@ -894,19 +961,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
let pred = nf_evar !evdref pred in
let p = nf_evar !evdref p in
let f cs b =
- let n = rel_context_length cs.cs_args in
+ let n = Context.Rel.length cs.cs_args in
let pi = lift n pred in (* liftn n 2 pred ? *)
let pi = beta_applist (pi, [build_dependent_constructor cs]) in
let csgn =
if not !allow_anonymous_refs then
- List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
+ List.map (set_name Anonymous) cs.cs_args
else
- List.map
- (fun (n, b, t) ->
- match n with
- Name _ -> (n, b, t)
- | Anonymous -> (Name Namegen.default_non_dependent_ident, b, t))
- cs.cs_args
+ List.map (map_name (function Name _ as n -> n
+ | Anonymous -> Name Namegen.default_non_dependent_ident))
+ cs.cs_args
in
let env_c = push_rel_context csgn env in
let bj = pretype (mk_tycon pi) env_c evdref lvar b in
@@ -915,9 +979,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
let b2 = f cstrs.(1) b2 in
let v =
let ind,_ = dest_ind_family indf in
- let ci = make_case_info env (fst ind) IfStyle in
+ let ci = make_case_info env.ExtraEnv.env (fst ind) IfStyle in
let pred = nf_evar !evdref pred in
- Typing.check_allowed_sort env !evdref ind cj.uj_val pred;
+ Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val pred;
mkCase (ci, pred, cj.uj_val, [|b1;b2|])
in
let cj = { uj_val = v; uj_type = p } in
@@ -925,51 +989,55 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_
| GCases (loc,sty,po,tml,eqns) ->
Cases.compile_cases loc sty
- ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
- tycon env (* loc *) (po,tml,eqns)
+ ((fun vtyc env evdref -> pretype vtyc (make_env env) evdref lvar),evdref)
+ tycon env.ExtraEnv.env (* loc *) (po,tml,eqns)
| GCast (loc,c,k) ->
let cj =
match k with
| CastCoerce ->
let cj = pretype empty_tycon env evdref lvar c in
- evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
+ evd_comb1 (Coercion.inh_coerce_to_base loc env.ExtraEnv.env) evdref cj
| CastConv t | CastVM t | CastNative t ->
let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in
let tj = pretype_type empty_valcon env evdref lvar t in
- let tval = nf_evar !evdref tj.utj_val in
- let cj = match k with
+ let tval = evd_comb1 (Evarsolve.refresh_universes
+ ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env)
+ evdref tj.utj_val in
+ let tval = nf_evar !evdref tval in
+ let cj, tval = match k with
| VMcast ->
let cj = pretype empty_tycon env evdref lvar c in
- let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
+ let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in
if not (occur_existential cty || occur_existential tval) then
- let (evd,b) = Reductionops.vm_infer_conv env !evdref cty tval in
- if b then (evdref := evd; cj)
+ let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in
+ if b then (evdref := evd; cj, tval)
else
- error_actual_type_loc loc env !evdref cj tval
- (ConversionFailed (env,cty,tval))
+ error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval
+ (ConversionFailed (env.ExtraEnv.env,cty,tval))
else user_err_loc (loc,"",str "Cannot check cast with vm: " ++
str "unresolved arguments remain.")
| NATIVEcast ->
let cj = pretype empty_tycon env evdref lvar c in
- let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
+ let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in
begin
- let (evd,b) = Nativenorm.native_infer_conv env !evdref cty tval in
- if b then (evdref := evd; cj)
+ let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in
+ if b then (evdref := evd; cj, tval)
else
- error_actual_type_loc loc env !evdref cj tval
- (ConversionFailed (env,cty,tval))
+ error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval
+ (ConversionFailed (env.ExtraEnv.env,cty,tval))
end
| _ ->
- pretype (mk_tycon tval) env evdref lvar c
+ pretype (mk_tycon tval) env evdref lvar c, tval
in
let v = mkCast (cj.uj_val, k, tval) in
{ uj_val = v; uj_type = tval }
in inh_conv_coerce_to_tycon loc env evdref cj tycon
and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
- let f (id,_,t) (subst,update) =
- let t = replace_vars subst t in
+ let f decl (subst,update) =
+ let id = get_id decl in
+ let t = replace_vars subst (get_type decl) in
let c, update =
try
let c = List.assoc id update in
@@ -978,11 +1046,11 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
with Not_found ->
try
let (n,_,t') = lookup_rel_id id (rel_context env) in
- if is_conv env !evdref t t' then mkRel n, update else raise Not_found
+ if is_conv env.ExtraEnv.env !evdref t t' then mkRel n, update else raise Not_found
with Not_found ->
try
- let (_,_,t') = lookup_named id env in
- if is_conv env !evdref t t' then mkVar id, update else raise Not_found
+ let t' = lookup_named id env |> get_type in
+ if is_conv env.ExtraEnv.env !evdref t t' then mkVar id, update else raise Not_found
with Not_found ->
user_err_loc (loc,"",str "Cannot interpret " ++
pr_existential_key !evdref evk ++
@@ -993,17 +1061,17 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
Array.map_of_list snd subst
(* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
-and pretype_type k0 resolve_tc valcon env evdref lvar = function
+and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function
| GHole (loc, knd, naming, None) ->
(match valcon with
| Some v ->
let s =
let sigma = !evdref in
- let t = Retyping.get_type_of env sigma v in
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ let t = Retyping.get_type_of env.ExtraEnv.env sigma v in
+ match kind_of_term (whd_all env.ExtraEnv.env sigma t) with
| Sort s -> s
| Evar ev when is_Type (existential_type sigma ev) ->
- evd_comb1 (define_evar_as_sort env) evdref ev
+ evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev
| _ -> anomaly (Pp.str "Found a type constraint which is not a type")
in
{ utj_val = v;
@@ -1016,18 +1084,19 @@ and pretype_type k0 resolve_tc valcon env evdref lvar = function
| c ->
let j = pretype k0 resolve_tc empty_tycon env evdref lvar c in
let loc = loc_of_glob_constr c in
- let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
+ let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env.ExtraEnv.env) evdref j in
match valcon with
| None -> tj
| Some v ->
- if e_cumul env evdref v tj.utj_val then tj
+ if e_cumul env.ExtraEnv.env evdref v tj.utj_val then tj
else
error_unexpected_type_loc
- (loc_of_glob_constr c) env !evdref tj.utj_val v
+ (loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v
let ise_pretype_gen flags env sigma lvar kind c =
+ let env = make_env env in
let evdref = ref sigma in
- let k0 = rel_context_length (rel_context env) in
+ let k0 = Context.Rel.length (rel_context env) in
let c' = match kind with
| WithoutTypeConstraint ->
(pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c).uj_val
@@ -1036,18 +1105,18 @@ let ise_pretype_gen flags env sigma lvar kind c =
| IsType ->
(pretype_type k0 flags.use_typeclasses empty_valcon env evdref lvar c).utj_val
in
- process_inference_flags flags env sigma (!evdref,c')
+ process_inference_flags flags env.ExtraEnv.env sigma (!evdref,c')
let default_inference_flags fail = {
use_typeclasses = true;
- use_unif_heuristics = true;
+ solve_unification_constraints = true;
use_hook = None;
fail_evar = fail;
expand_evars = true }
let no_classes_no_fail_inference_flags = {
use_typeclasses = false;
- use_unif_heuristics = true;
+ solve_unification_constraints = true;
use_hook = None;
fail_evar = false;
expand_evars = true }
@@ -1068,19 +1137,21 @@ let on_judgment f j =
{uj_val = c; uj_type = t}
let understand_judgment env sigma c =
+ let env = make_env env in
let evdref = ref sigma in
- let k0 = rel_context_length (rel_context env) in
+ let k0 = Context.Rel.length (rel_context env) in
let j = pretype k0 true empty_tycon env evdref empty_lvar c in
let j = on_judgment (fun c ->
- let evd, c = process_inference_flags all_and_fail_flags env sigma (!evdref,c) in
+ let evd, c = process_inference_flags all_and_fail_flags env.ExtraEnv.env sigma (!evdref,c) in
evdref := evd; c) j
in j, Evd.evar_universe_context !evdref
let understand_judgment_tcc env evdref c =
- let k0 = rel_context_length (rel_context env) in
+ let env = make_env env in
+ let k0 = Context.Rel.length (rel_context env) in
let j = pretype k0 true empty_tycon env evdref empty_lvar c in
on_judgment (fun c ->
- let (evd,c) = process_inference_flags all_no_fail_flags env Evd.empty (!evdref,c) in
+ let (evd,c) = process_inference_flags all_no_fail_flags env.ExtraEnv.env Evd.empty (!evdref,c) in
evdref := evd; c) j
let ise_pretype_gen_ctx flags env sigma lvar kind c =
@@ -1106,3 +1177,32 @@ let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=W
let understand_ltac flags env sigma lvar kind c =
ise_pretype_gen flags env sigma lvar kind c
+
+let constr_flags = {
+ use_typeclasses = true;
+ solve_unification_constraints = true;
+ use_hook = None;
+ fail_evar = true;
+ expand_evars = true }
+
+(* Fully evaluate an untyped constr *)
+let type_uconstr ?(flags = constr_flags)
+ ?(expected_type = WithoutTypeConstraint) ist c =
+ { delayed = begin fun env sigma ->
+ let { closure; term } = c in
+ let vars = {
+ ltac_constrs = closure.typed;
+ ltac_uconstrs = closure.untyped;
+ ltac_idents = closure.idents;
+ ltac_genargs = Id.Map.empty;
+ } in
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = understand_ltac flags env sigma vars expected_type term in
+ Sigma.Unsafe.of_pair (c, sigma)
+ end }
+
+let pretype k0 resolve_tc typcon env evdref lvar t =
+ pretype k0 resolve_tc typcon (make_env env) evdref lvar t
+
+let pretype_type k0 resolve_tc valcon env evdref lvar t =
+ pretype_type k0 resolve_tc valcon (make_env env) evdref lvar t
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index ac899a78..0f3f7c3c 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -29,7 +29,7 @@ type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
type var_map = Pattern.constr_under_binders Id.Map.t
type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t
-type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t
+type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t
type ltac_var_map = {
ltac_constrs : var_map;
@@ -47,14 +47,19 @@ val empty_lvar : ltac_var_map
type glob_constr_ltac_closure = ltac_var_map * glob_constr
type pure_open_constr = evar_map * constr
+type inference_hook = env -> evar_map -> evar -> evar_map * constr
+
type inference_flags = {
use_typeclasses : bool;
- use_unif_heuristics : bool;
- use_hook : (env -> evar_map -> evar -> constr) option;
+ solve_unification_constraints : bool;
+ use_hook : inference_hook option;
fail_evar : bool;
expand_evars : bool
}
+type 'a delayed_open =
+ { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
+
val default_inference_flags : bool -> inference_flags
val no_classes_no_fail_inference_flags : inference_flags
@@ -114,6 +119,11 @@ val understand_judgment : env -> evar_map ->
val understand_judgment_tcc : env -> evar_map ref ->
glob_constr -> unsafe_judgment
+val type_uconstr :
+ ?flags:inference_flags ->
+ ?expected_type:typing_constraint ->
+ Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open
+
(** Trying to solve remaining evars and remaining conversion problems
possibly using type classes, heuristics, external tactic solver
hook depending on given flags. *)
@@ -130,6 +140,10 @@ val solve_remaining_evars : inference_flags ->
val check_evars_are_solved :
env -> (* current map: *) evar_map -> (* map to check: *) pending -> unit
+(** [check_evars env initial_sigma extended_sigma c] fails if some
+ new unresolved evar remains in [c] *)
+val check_evars : env -> evar_map -> evar_map -> constr -> unit
+
(**/**)
(** Internal of Pretyping... *)
val pretype :
@@ -148,12 +162,9 @@ val ise_pretype_gen :
(** To embed constr in glob_constr *)
-val constr_in : constr -> Dyn.t
-val constr_out : Dyn.t -> constr
-
-val interp_sort : evar_map -> glob_sort -> evar_map * sorts
+val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts
val interp_elimination_sort : glob_sort -> sorts_family
val genarg_interp_hook :
- (types -> env -> evar_map -> Genarg.typed_generic_argument Id.Map.t ->
+ (types -> env -> evar_map -> unbound_ltac_var_map ->
Genarg.glob_generic_argument -> constr * evar_map) Hook.t
diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index a644e3d1..c8b3307d 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -1,7 +1,5 @@
Locusops
-Termops
-Namegen
-Evd
+Pretype_errors
Reductionops
Inductiveops
Vnorm
@@ -9,9 +7,8 @@ Arguments_renaming
Nativenorm
Retyping
Cbv
-Pretype_errors
Find_subterm
-Evarutil
+Evardefine
Evarsolve
Recordops
Evarconv
diff --git a/pretyping/program.ml b/pretyping/program.ml
index 0bd121f6..62aedcfb 100644
--- a/pretyping/program.ml
+++ b/pretyping/program.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -15,10 +15,12 @@ open Term
let make_dir l = DirPath.make (List.rev_map Id.of_string l)
let find_reference locstr dir s =
- let sp = Libnames.make_path (make_dir dir) (Id.of_string s) in
+ let dp = make_dir dir in
+ let sp = Libnames.make_path dp (Id.of_string s) in
try Nametab.global_of_path sp
with Not_found ->
- anomaly ~label:locstr (Pp.str "cannot find" ++ spc () ++ Libnames.pr_path sp)
+ user_err_loc (Loc.ghost, "", str "Library " ++ Libnames.pr_dirpath dp ++
+ str " has to be required first.")
let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s
let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s)
@@ -67,3 +69,43 @@ let mk_coq_and l =
(fun c conj ->
mkApp (and_typ, [| c ; conj |]))
l
+
+(* true = transparent by default, false = opaque if possible *)
+let proofs_transparency = ref true
+let program_cases = ref true
+let program_generalized_coercion = ref true
+
+let set_proofs_transparency = (:=) proofs_transparency
+let get_proofs_transparency () = !proofs_transparency
+
+let is_program_generalized_coercion () = !program_generalized_coercion
+let is_program_cases () = !program_cases
+
+open Goptions
+
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "preferred transparency of Program obligations";
+ optkey = ["Transparent";"Obligations"];
+ optread = get_proofs_transparency;
+ optwrite = set_proofs_transparency; }
+
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "program cases";
+ optkey = ["Program";"Cases"];
+ optread = (fun () -> !program_cases);
+ optwrite = (:=) program_cases }
+
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "program generalized coercion";
+ optkey = ["Program";"Generalized";"Coercion"];
+ optread = (fun () -> !program_generalized_coercion);
+ optwrite = (:=) program_generalized_coercion }
diff --git a/pretyping/program.mli b/pretyping/program.mli
index b7ebcbc9..023ff8ca 100644
--- a/pretyping/program.mli
+++ b/pretyping/program.mli
@@ -37,3 +37,7 @@ val mk_coq_not : constr -> constr
(** Polymorphic application of delayed references *)
val papp : Evd.evar_map ref -> (unit -> global_reference) -> constr array -> constr
+
+val get_proofs_transparency : unit -> bool
+val is_program_cases : unit -> bool
+val is_program_generalized_coercion : unit -> bool
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 560beb6f..284af0cb 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -13,7 +13,7 @@
(* This file registers properties of records: projections and
canonical structures *)
-open Errors
+open CErrors
open Util
open Pp
open Names
@@ -176,7 +176,7 @@ let cs_pattern_of_constr t =
App (f,vargs) ->
begin
try Const_cs (global_of_constr f) , None, Array.to_list vargs
- with e when Errors.noncritical e -> raise Not_found
+ with e when CErrors.noncritical e -> raise Not_found
end
| Rel n -> Default_cs, Some n, []
| Prod (_,a,b) when not (Termops.dependent (mkRel 1) b) -> Prod_cs, None, [a; Termops.pop b]
@@ -184,11 +184,18 @@ let cs_pattern_of_constr t =
| _ ->
begin
try Const_cs (global_of_constr t) , None, []
- with e when Errors.noncritical e -> raise Not_found
+ with e when CErrors.noncritical e -> raise Not_found
end
+let warn_projection_no_head_constant =
+ CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker"
+ (fun (t,con_pp,proji_sp_pp) ->
+ strbrk "Projection value has no head constant: "
+ ++ Termops.print_constr t ++ strbrk " in canonical instance "
+ ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.")
+
(* Intended to always succeed *)
-let compute_canonical_projections (con,ind) =
+let compute_canonical_projections warn (con,ind) =
let env = Global.env () in
let ctx = Univ.instantiate_univ_context (Environ.constant_context env con) in
let u = Univ.UContext.instance ctx in
@@ -213,13 +220,10 @@ let compute_canonical_projections (con,ind) =
let patt, n , args = cs_pattern_of_constr t in
((ConstRef proji_sp, patt, t, n, args) :: l)
with Not_found ->
- if Flags.is_verbose () then
- (let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con)
+ let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con)
and proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in
- msg_warning (strbrk "No global reference exists for projection value"
- ++ Termops.print_constr t ++ strbrk " in instance "
- ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it."));
- l
+ if warn then warn_projection_no_head_constant (t,con_pp,proji_sp_pp);
+ l
end
| _ -> l)
[] lps in
@@ -235,9 +239,15 @@ let pr_cs_pattern = function
| Default_cs -> str "_"
| Sort_cs s -> Termops.pr_sort_family s
-let open_canonical_structure i (_,o) =
- if Int.equal i 1 then
- let lo = compute_canonical_projections o in
+let warn_redundant_canonical_projection =
+ CWarnings.create ~name:"redundant-canonical-projection" ~category:"typechecker"
+ (fun (hd_val,prj,new_can_s,old_can_s) ->
+ strbrk "Ignoring canonical projection to " ++ hd_val
+ ++ strbrk " by " ++ prj ++ strbrk " in "
+ ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s)
+
+let add_canonical_structure warn o =
+ let lo = compute_canonical_projections warn o in
List.iter (fun ((proj,(cs_pat,_ as pat)),s) ->
let l = try Refmap.find proj !object_table with Not_found -> [] in
let ocs = try Some (assoc_pat cs_pat l)
@@ -245,17 +255,18 @@ let open_canonical_structure i (_,o) =
in match ocs with
| None -> object_table := Refmap.add proj ((pat,s)::l) !object_table;
| Some (c, cs) ->
- if Flags.is_verbose () then
let old_can_s = (Termops.print_constr cs.o_DEF)
and new_can_s = (Termops.print_constr s.o_DEF) in
let prj = (Nametab.pr_global_env Id.Set.empty proj)
and hd_val = (pr_cs_pattern cs_pat) in
- msg_warning (strbrk "Ignoring canonical projection to " ++ hd_val
- ++ strbrk " by " ++ prj ++ strbrk " in "
- ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s)) lo
+ if warn then warn_redundant_canonical_projection (hd_val,prj,new_can_s,old_can_s))
+ lo
+
+let open_canonical_structure i (_, o) =
+ if Int.equal i 1 then add_canonical_structure false o
-let cache_canonical_structure o =
- open_canonical_structure 1 o
+let cache_canonical_structure (_, o) =
+ add_canonical_structure true o
let subst_canonical_structure (subst,(cst,ind as obj)) =
(* invariant: cst is an evaluable reference. Thus we can take *)
@@ -299,7 +310,7 @@ let check_and_decompose_canonical_structure ref =
| Construct ((indsp,1),u) -> indsp
| _ -> error_not_structure ref in
let s = try lookup_structure indsp with Not_found -> error_not_structure ref in
- let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in
+ let ntrue_projs = List.count snd s.s_PROJKIND in
if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then
error_not_structure ref;
(sp,indsp)
@@ -317,7 +328,7 @@ let is_open_canonical_projection env sigma (c,args) =
(** Check if there is some canonical projection attached to this structure *)
let _ = Refmap.find ref !object_table in
try
- let arg = whd_betadeltaiota env sigma (Stack.nth args n) in
+ let arg = whd_all env sigma (Stack.nth args n) in
let hd = match kind_of_term arg with App (hd, _) -> hd | _ -> arg in
not (isConstruct hd)
with Failure _ -> false
diff --git a/pretyping/redops.ml b/pretyping/redops.ml
index c188995a..7d65925e 100644
--- a/pretyping/redops.ml
+++ b/pretyping/redops.ml
@@ -14,25 +14,29 @@ let make_red_flag l =
let rec add_flag red = function
| [] -> red
| FBeta :: lf -> add_flag { red with rBeta = true } lf
- | FIota :: lf -> add_flag { red with rIota = true } lf
+ | FMatch :: lf -> add_flag { red with rMatch = true } lf
+ | FFix :: lf -> add_flag { red with rFix = true } lf
+ | FCofix :: lf -> add_flag { red with rCofix = true } lf
| FZeta :: lf -> add_flag { red with rZeta = true } lf
| FConst l :: lf ->
if red.rDelta then
- Errors.error
+ CErrors.error
"Cannot set both constants to unfold and constants not to unfold";
add_flag { red with rConst = union_consts red.rConst l } lf
| FDeltaBut l :: lf ->
if red.rConst <> [] && not red.rDelta then
- Errors.error
+ CErrors.error
"Cannot set both constants to unfold and constants not to unfold";
add_flag
{ red with rConst = union_consts red.rConst l; rDelta = true }
lf
in
add_flag
- {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []}
+ {rBeta = false; rMatch = false; rFix = false; rCofix = false;
+ rZeta = false; rDelta = false; rConst = []}
l
let all_flags =
- {rBeta = true; rIota = true; rZeta = true; rDelta = true; rConst = []}
+ {rBeta = true; rMatch = true; rFix = true; rCofix = true;
+ rZeta = true; rDelta = true; rConst = []}
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 13b7fb40..297f0a1a 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -6,16 +6,16 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Term
open Vars
-open Context
open Termops
open Univ
open Evd
open Environ
+open Context.Rel.Declaration
exception Elimconst
@@ -26,6 +26,19 @@ exception Elimconst
their parameters in its stack.
*)
+let refolding_in_reduction = ref false
+let _ = Goptions.declare_bool_option {
+ Goptions.optsync = true; Goptions.optdepr = false;
+ Goptions.optname =
+ "Perform refolding of fixpoints/constants like cbn during reductions";
+ Goptions.optkey = ["Refolding";"Reduction"];
+ Goptions.optread = (fun () -> !refolding_in_reduction);
+ Goptions.optwrite = (fun a -> refolding_in_reduction:=a);
+}
+
+let get_refolding_in_reduction () = !refolding_in_reduction
+let set_refolding_in_reduction = (:=) refolding_in_reduction
+
(** Machinery to custom the behavior of the reduction *)
module ReductionBehaviour = struct
open Globnames
@@ -153,9 +166,6 @@ module Cst_stack = struct
let empty = []
let is_empty = CList.is_empty
- let sanity x y =
- assert(Term.eq_constr x y)
-
let drop_useless = function
| _ :: ((_,_,[])::_ as q) -> q
| l -> l
@@ -164,9 +174,9 @@ module Cst_stack = struct
let append2cst = function
| (c,params,[]) -> (c, h::params, [])
| (c,params,((i,t)::q)) when i = pred (Array.length t) ->
- let () = sanity h t.(i) in (c, params, q)
+ (c, params, q)
| (c,params,(i,t)::q) ->
- let () = sanity h t.(i) in (c, params, (succ i,t)::q)
+ (c, params, (succ i,t)::q)
in
drop_useless (List.map append2cst cst_l)
@@ -573,7 +583,7 @@ type state = constr * constr Stack.t
type contextual_reduction_function = env -> evar_map -> constr -> constr
type reduction_function = contextual_reduction_function
type local_reduction_function = evar_map -> constr -> constr
-type e_reduction_function = env -> evar_map -> constr -> evar_map * constr
+type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma }
type contextual_stack_reduction_function =
env -> evar_map -> constr -> constr * constr list
@@ -594,9 +604,7 @@ let pr_state (tm,sk) =
(*** Reduction Functions Operators ***)
(*************************************)
-let safe_evar_value sigma ev =
- try Some (Evd.existential_value sigma ev)
- with NotInstantiatedEvar | Not_found -> None
+let safe_evar_value = Evarutil.safe_evar_value
let safe_meta_value sigma ev =
try Some (Evd.meta_value sigma ev)
@@ -608,7 +616,7 @@ let strong whdfun env sigma t =
strongrec env t
let local_strong whdfun sigma =
- let rec strongrec t = map_constr strongrec (whdfun sigma t) in
+ let rec strongrec t = Constr.map strongrec (whdfun sigma t) in
strongrec
let rec strong_prodspine redfun sigma c =
@@ -621,36 +629,21 @@ let rec strong_prodspine redfun sigma c =
(*** Reduction using bindingss ***)
(*************************************)
-(* Local *)
-let nored = Closure.RedFlags.no_red
-let beta = Closure.beta
-let eta = Closure.RedFlags.mkflags [Closure.RedFlags.fETA]
-let zeta = Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]
-let betaiota = Closure.betaiota
-let betaiotazeta = Closure.betaiotazeta
-
-(* Contextual *)
-let delta = Closure.RedFlags.mkflags [Closure.RedFlags.fDELTA]
-let betalet = Closure.RedFlags.mkflags [Closure.RedFlags.fBETA;Closure.RedFlags.fZETA]
-let betaetalet = Closure.RedFlags.red_add betalet Closure.RedFlags.fETA
-let betadelta = Closure.RedFlags.red_add betalet Closure.RedFlags.fDELTA
-let betadeltaeta = Closure.RedFlags.red_add betadelta Closure.RedFlags.fETA
-let betadeltaiota = Closure.RedFlags.red_add betadelta Closure.RedFlags.fIOTA
-let betadeltaiota_nolet = Closure.betadeltaiotanolet
-let betadeltaiotaeta = Closure.RedFlags.red_add betadeltaiota Closure.RedFlags.fETA
+let eta = CClosure.RedFlags.mkflags [CClosure.RedFlags.fETA]
(* Beta Reduction tools *)
-let apply_subst recfun env cst_l t stack =
+let apply_subst recfun env refold cst_l t stack =
let rec aux env cst_l t stack =
match (Stack.decomp stack,kind_of_term t) with
| Some (h,stacktl), Lambda (_,_,c) ->
- aux (h::env) (Cst_stack.add_param h cst_l) c stacktl
+ let cst_l' = if refold then Cst_stack.add_param h cst_l else cst_l in
+ aux (h::env) cst_l' c stacktl
| _ -> recfun cst_l (substl env t, stack)
in aux env cst_l t stack
let stacklam recfun env t stack =
- apply_subst (fun _ -> recfun) env Cst_stack.empty t stack
+ apply_subst (fun _ -> recfun) env false Cst_stack.empty t stack
let beta_applist (c,l) =
stacklam Stack.zip [] c (Stack.append_app_list l Stack.empty)
@@ -715,11 +708,16 @@ let contract_cofix ?env ?reference (bodynum,(names,types,bodies as typedbodies))
substl closure bodies.(bodynum)
(** Similar to the "fix" case below *)
-let reduce_and_refold_cofix recfun env cst_l cofix sk =
- let raw_answer = contract_cofix ~env ?reference:(Cst_stack.reference cst_l) cofix in
+let reduce_and_refold_cofix recfun env refold cst_l cofix sk =
+ let raw_answer =
+ let env = if refold then Some env else None in
+ contract_cofix ?env ?reference:(Cst_stack.reference cst_l) cofix in
apply_subst
- (fun x (t,sk') -> recfun x (Cst_stack.best_replace (mkCoFix cofix) cst_l t,sk'))
- [] Cst_stack.empty raw_answer sk
+ (fun x (t,sk') ->
+ let t' =
+ if refold then Cst_stack.best_replace (mkCoFix cofix) cst_l t else t in
+ recfun x (t',sk'))
+ [] refold Cst_stack.empty raw_answer sk
let reduce_mind_case mia =
match kind_of_term mia.mconstr with
@@ -755,11 +753,18 @@ let contract_fix ?env ?reference ((recindices,bodynum),(names,types,bodies as ty
replace the fixpoint by the best constant from [cst_l]
Other rels are directly substituted by constants "magically found from the
context" in contract_fix *)
-let reduce_and_refold_fix recfun env cst_l fix sk =
- let raw_answer = contract_fix ~env ?reference:(Cst_stack.reference cst_l) fix in
+let reduce_and_refold_fix recfun env refold cst_l fix sk =
+ let raw_answer =
+ let env = if refold then None else Some env in
+ contract_fix ?env ?reference:(Cst_stack.reference cst_l) fix in
apply_subst
- (fun x (t,sk') -> recfun x (Cst_stack.best_replace (mkFix fix) cst_l t,sk'))
- [] Cst_stack.empty raw_answer sk
+ (fun x (t,sk') ->
+ let t' =
+ if refold then
+ Cst_stack.best_replace (mkFix fix) cst_l t
+ else t
+ in recfun x (t',sk'))
+ [] refold Cst_stack.empty raw_answer sk
let fix_recarg ((recindices,bodynum),_) stack =
assert (0 <= bodynum && bodynum < Array.length recindices);
@@ -799,28 +804,31 @@ let equal_stacks (x, l) (y, l') =
| None -> false
| Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2)
-let rec whd_state_gen ?csts tactic_mode flags env sigma =
+let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma =
+ let open Context.Named.Declaration in
let rec whrec cst_l (x, stack as s) =
let () = if !debug_RAKAM then
let open Pp in
- pp (h 0 (str "<<" ++ Termops.print_constr x ++
+ Feedback.msg_notice
+ (h 0 (str "<<" ++ Termops.print_constr x ++
str "|" ++ cut () ++ Cst_stack.pr cst_l ++
str "|" ++ cut () ++ Stack.pr Termops.print_constr stack ++
- str ">>") ++ fnl ())
+ str ">>"))
in
let fold () =
let () = if !debug_RAKAM then
- let open Pp in pp (str "<><><><><>" ++ fnl ()) in
- if tactic_mode then (Stack.best_state s cst_l,Cst_stack.empty) else (s,cst_l)
+ let open Pp in Feedback.msg_notice (str "<><><><><>") in
+ (s,cst_l)
in
match kind_of_term x with
- | Rel n when Closure.RedFlags.red_set flags Closure.RedFlags.fDELTA ->
+ | Rel n when CClosure.RedFlags.red_set flags CClosure.RedFlags.fDELTA ->
(match lookup_rel n env with
- | (_,Some body,_) -> whrec Cst_stack.empty (lift n body, stack)
+ | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n body, stack)
| _ -> fold ())
- | Var id when Closure.RedFlags.red_set flags (Closure.RedFlags.fVAR id) ->
+ | Var id when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fVAR id) ->
(match lookup_named id env with
- | (_,Some body,_) -> whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack)
+ | LocalDef (_,body,_) ->
+ whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (body, stack)
| _ -> fold ())
| Evar ev ->
(match safe_evar_value sigma ev with
@@ -830,12 +838,13 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
(match safe_meta_value sigma ev with
| Some body -> whrec cst_l (body, stack)
| None -> fold ())
- | Const (c,u as const) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST c) ->
+ | Const (c,u as const) when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) ->
(match constant_opt_value_in env const with
| None -> fold ()
| Some body ->
if not tactic_mode
- then whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack)
+ then whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l)
+ (body, stack)
else (* Looks for ReductionBehaviour *)
match ReductionBehaviour.get (Globnames.ConstRef c) with
| None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack)
@@ -870,7 +879,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
whrec Cst_stack.empty
(arg,Stack.Cst(Stack.Cst_const const,curr,remains,bef,cst_l)::s')
)
- | Proj (p, c) when Closure.RedFlags.red_projection flags p ->
+ | Proj (p, c) when CClosure.RedFlags.red_projection flags p ->
(let pb = lookup_projection p env in
let kn = Projection.constant p in
let npars = pb.Declarations.proj_npars
@@ -911,21 +920,21 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
(arg,Stack.Cst(Stack.Cst_proj p,curr,remains,
Stack.append_app [|c|] bef,cst_l)::s'))
- | LetIn (_,b,_,c) when Closure.RedFlags.red_set flags Closure.RedFlags.fZETA ->
- apply_subst whrec [b] cst_l c stack
+ | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA ->
+ apply_subst whrec [b] refold cst_l c stack
| Cast (c,_,_) -> whrec cst_l (c, stack)
| App (f,cl) ->
whrec
- (Cst_stack.add_args cl cst_l)
+ (if refold then Cst_stack.add_args cl cst_l else cst_l)
(f, Stack.append_app cl stack)
| Lambda (na,t,c) ->
(match Stack.decomp stack with
- | Some _ when Closure.RedFlags.red_set flags Closure.RedFlags.fBETA ->
- apply_subst whrec [] cst_l x stack
- | None when Closure.RedFlags.red_set flags Closure.RedFlags.fETA ->
- let env' = push_rel (na,None,t) env in
- let whrec' = whd_state_gen tactic_mode flags env' sigma in
- (match kind_of_term (Stack.zip ~refold:true (fst (whrec' (c, Stack.empty)))) with
+ | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA ->
+ apply_subst whrec [] refold cst_l x stack
+ | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA ->
+ let env' = push_rel (LocalAssum (na,t)) env in
+ let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in
+ (match kind_of_term (Stack.zip ~refold (fst (whrec' (c, Stack.empty)))) with
| App (f,cl) ->
let napp = Array.length cl in
if napp > 0 then
@@ -950,16 +959,18 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
whrec Cst_stack.empty (arg, Stack.Fix(f,bef,cst_l)::s'))
| Construct ((ind,c),u) ->
- if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+ let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in
+ let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in
+ if use_match || use_fix then
match Stack.strip_app stack with
- |args, (Stack.Case(ci, _, lf,_)::s') ->
+ |args, (Stack.Case(ci, _, lf,_)::s') when use_match ->
whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s')
- |args, (Stack.Proj (n,m,p,_)::s') ->
+ |args, (Stack.Proj (n,m,p,_)::s') when use_match ->
whrec Cst_stack.empty (Stack.nth args (n+m), s')
- |args, (Stack.Fix (f,s',cst_l)::s'') ->
+ |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix ->
let x' = Stack.zip(x,args) in
let out_sk = s' @ (Stack.append_app [|x'|] s'') in
- reduce_and_refold_fix whrec env cst_l f out_sk
+ reduce_and_refold_fix whrec env refold cst_l f out_sk
|args, (Stack.Cst (const,curr,remains,s',cst_l) :: s'') ->
let x' = Stack.zip(x,args) in
begin match remains with
@@ -969,7 +980,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
(match constant_opt_value_in env const with
| None -> fold ()
| Some body ->
- whrec (Cst_stack.add_cst (mkConstU const) cst_l)
+ whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l)
(body, s' @ (Stack.append_app [|x'|] s'')))
| Stack.Cst_proj p ->
let pb = lookup_projection p env in
@@ -988,35 +999,37 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma =
Stack.Cst (const,next,remains',s' @ (Stack.append_app [|x'|] bef),cst_l) :: s''')
end
|_, (Stack.App _|Stack.Update _|Stack.Shift _)::_ -> assert false
- |_, [] -> fold ()
+ |_, _ -> fold ()
else fold ()
| CoFix cofix ->
- if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+ if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then
match Stack.strip_app stack with
|args, ((Stack.Case _ |Stack.Proj _)::s') ->
- reduce_and_refold_cofix whrec env cst_l cofix stack
+ reduce_and_refold_cofix whrec env refold cst_l cofix stack
|_ -> fold ()
else fold ()
| Rel _ | Var _ | Const _ | LetIn _ | Proj _ -> fold ()
| Sort _ | Ind _ | Prod _ -> fold ()
in
- whrec (Option.default Cst_stack.empty csts)
+ fun xs ->
+ let (s,cst_l as res) = whrec (Option.default Cst_stack.empty csts) xs in
+ if tactic_mode then (Stack.best_state s cst_l,Cst_stack.empty) else res
(** reduction machine without global env and refold machinery *)
let local_whd_state_gen flags sigma =
let rec whrec (x, stack as s) =
match kind_of_term x with
- | LetIn (_,b,_,c) when Closure.RedFlags.red_set flags Closure.RedFlags.fZETA ->
+ | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA ->
stacklam whrec [b] c stack
| Cast (c,_,_) -> whrec (c, stack)
| App (f,cl) -> whrec (f, Stack.append_app cl stack)
| Lambda (_,_,c) ->
(match Stack.decomp stack with
- | Some (a,m) when Closure.RedFlags.red_set flags Closure.RedFlags.fBETA ->
+ | Some (a,m) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA ->
stacklam whrec [a] c m
- | None when Closure.RedFlags.red_set flags Closure.RedFlags.fETA ->
+ | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA ->
(match kind_of_term (Stack.zip (whrec (c, Stack.empty))) with
| App (f,cl) ->
let napp = Array.length cl in
@@ -1032,7 +1045,7 @@ let local_whd_state_gen flags sigma =
| _ -> s)
| _ -> s)
- | Proj (p,c) when Closure.RedFlags.red_projection flags p ->
+ | Proj (p,c) when CClosure.RedFlags.red_projection flags p ->
(let pb = lookup_projection p (Global.env ()) in
whrec (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg,
p, Cst_stack.empty)
@@ -1057,21 +1070,23 @@ let local_whd_state_gen flags sigma =
| None -> s)
| Construct ((ind,c),u) ->
- if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+ let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in
+ let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in
+ if use_match || use_fix then
match Stack.strip_app stack with
- |args, (Stack.Case(ci, _, lf,_)::s') ->
+ |args, (Stack.Case(ci, _, lf,_)::s') when use_match ->
whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s')
- |args, (Stack.Proj (n,m,p,_) :: s') ->
+ |args, (Stack.Proj (n,m,p,_) :: s') when use_match ->
whrec (Stack.nth args (n+m), s')
- |args, (Stack.Fix (f,s',cst)::s'') ->
+ |args, (Stack.Fix (f,s',cst)::s'') when use_fix ->
let x' = Stack.zip(x,args) in
whrec (contract_fix f, s' @ (Stack.append_app [|x'|] s''))
|_, (Stack.App _|Stack.Update _|Stack.Shift _|Stack.Cst _)::_ -> assert false
- |_, [] -> s
+ |_, _ -> s
else s
| CoFix cofix ->
- if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+ if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then
match Stack.strip_app stack with
|args, ((Stack.Case _ | Stack.Proj _)::s') ->
whrec (contract_cofix cofix, stack)
@@ -1083,7 +1098,7 @@ let local_whd_state_gen flags sigma =
whrec
let raw_whd_state_gen flags env =
- let f sigma s = fst (whd_state_gen false flags env sigma s) in
+ let f sigma s = fst (whd_state_gen (get_refolding_in_reduction ()) false flags env sigma s) in
f
let stack_red_of_state_red f =
@@ -1093,7 +1108,7 @@ let stack_red_of_state_red f =
(* Drops the Cst_stack *)
let iterate_whd_gen refold flags env sigma s =
let rec aux t =
- let (hd,sk),_ = whd_state_gen refold flags env sigma (t,Stack.empty) in
+ let (hd,sk),_ = whd_state_gen refold false flags env sigma (t,Stack.empty) in
let whd_sk = Stack.map aux sk in
Stack.zip ~refold (hd,whd_sk)
in aux s
@@ -1103,109 +1118,72 @@ let red_of_state_red f sigma x =
(* 0. No Reduction Functions *)
-let whd_nored_state = local_whd_state_gen nored
+let whd_nored_state = local_whd_state_gen CClosure.nored
let whd_nored_stack = stack_red_of_state_red whd_nored_state
let whd_nored = red_of_state_red whd_nored_state
(* 1. Beta Reduction Functions *)
-let whd_beta_state = local_whd_state_gen beta
+let whd_beta_state = local_whd_state_gen CClosure.beta
let whd_beta_stack = stack_red_of_state_red whd_beta_state
let whd_beta = red_of_state_red whd_beta_state
-(* Nouveau ! *)
-let whd_betaetalet_state = local_whd_state_gen betaetalet
-let whd_betaetalet_stack = stack_red_of_state_red whd_betaetalet_state
-let whd_betaetalet = red_of_state_red whd_betaetalet_state
-
-let whd_betalet_state = local_whd_state_gen betalet
+let whd_betalet_state = local_whd_state_gen CClosure.betazeta
let whd_betalet_stack = stack_red_of_state_red whd_betalet_state
let whd_betalet = red_of_state_red whd_betalet_state
(* 2. Delta Reduction Functions *)
-let whd_delta_state e = raw_whd_state_gen delta e
+let whd_delta_state e = raw_whd_state_gen CClosure.delta e
let whd_delta_stack env = stack_red_of_state_red (whd_delta_state env)
let whd_delta env = red_of_state_red (whd_delta_state env)
-let whd_betadelta_state e = raw_whd_state_gen betadelta e
-let whd_betadelta_stack env =
- stack_red_of_state_red (whd_betadelta_state env)
-let whd_betadelta env =
- red_of_state_red (whd_betadelta_state env)
+let whd_betadeltazeta_state e = raw_whd_state_gen CClosure.betadeltazeta e
+let whd_betadeltazeta_stack env =
+ stack_red_of_state_red (whd_betadeltazeta_state env)
+let whd_betadeltazeta env =
+ red_of_state_red (whd_betadeltazeta_state env)
-let whd_betadeltaeta_state e = raw_whd_state_gen betadeltaeta e
-let whd_betadeltaeta_stack env =
- stack_red_of_state_red (whd_betadeltaeta_state env)
-let whd_betadeltaeta env =
- red_of_state_red (whd_betadeltaeta_state env)
-
(* 3. Iota reduction Functions *)
-let whd_betaiota_state = local_whd_state_gen betaiota
+let whd_betaiota_state = local_whd_state_gen CClosure.betaiota
let whd_betaiota_stack = stack_red_of_state_red whd_betaiota_state
let whd_betaiota = red_of_state_red whd_betaiota_state
-let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta
+let whd_betaiotazeta_state = local_whd_state_gen CClosure.betaiotazeta
let whd_betaiotazeta_stack = stack_red_of_state_red whd_betaiotazeta_state
let whd_betaiotazeta = red_of_state_red whd_betaiotazeta_state
-let whd_betadeltaiota_state env = raw_whd_state_gen betadeltaiota env
-let whd_betadeltaiota_stack env =
- stack_red_of_state_red (whd_betadeltaiota_state env)
-let whd_betadeltaiota env =
- red_of_state_red (whd_betadeltaiota_state env)
-
-let whd_betadeltaiotaeta_state env = raw_whd_state_gen betadeltaiotaeta env
-let whd_betadeltaiotaeta_stack env =
- stack_red_of_state_red (whd_betadeltaiotaeta_state env)
-let whd_betadeltaiotaeta env =
- red_of_state_red (whd_betadeltaiotaeta_state env)
+let whd_all_state env = raw_whd_state_gen CClosure.all env
+let whd_all_stack env =
+ stack_red_of_state_red (whd_all_state env)
+let whd_all env =
+ red_of_state_red (whd_all_state env)
-let whd_betadeltaiota_nolet_state env = raw_whd_state_gen betadeltaiota_nolet env
-let whd_betadeltaiota_nolet_stack env =
- stack_red_of_state_red (whd_betadeltaiota_nolet_state env)
-let whd_betadeltaiota_nolet env =
- red_of_state_red (whd_betadeltaiota_nolet_state env)
+let whd_allnolet_state env = raw_whd_state_gen CClosure.allnolet env
+let whd_allnolet_stack env =
+ stack_red_of_state_red (whd_allnolet_state env)
+let whd_allnolet env =
+ red_of_state_red (whd_allnolet_state env)
-(* 4. Eta reduction Functions *)
+(* 4. Ad-hoc eta reduction, does not subsitute evars *)
-let whd_eta c = Stack.zip (local_whd_state_gen eta Evd.empty (c,Stack.empty))
+let shrink_eta c = Stack.zip (local_whd_state_gen eta Evd.empty (c,Stack.empty))
(* 5. Zeta Reduction Functions *)
-let whd_zeta c = Stack.zip (local_whd_state_gen zeta Evd.empty (c,Stack.empty))
+let whd_zeta_state = local_whd_state_gen CClosure.zeta
+let whd_zeta_stack = stack_red_of_state_red whd_zeta_state
+let whd_zeta = red_of_state_red whd_zeta_state
(****************************************************************************)
(* Reduction Functions *)
(****************************************************************************)
(* Replacing defined evars for error messages *)
-let rec whd_evar sigma c =
- match kind_of_term c with
- | Evar ev ->
- let (evk, args) = ev in
- let args = Array.map (fun c -> whd_evar sigma c) args in
- (match safe_evar_value sigma (evk, args) with
- Some c -> whd_evar sigma c
- | None -> c)
- | Sort (Type u) ->
- let u' = Evd.normalize_universe sigma u in
- if u' == u then c else mkSort (Sorts.sort_of_univ u')
- | Const (c', u) when not (Univ.Instance.is_empty u) ->
- let u' = Evd.normalize_universe_instance sigma u in
- if u' == u then c else mkConstU (c', u')
- | Ind (i, u) when not (Univ.Instance.is_empty u) ->
- let u' = Evd.normalize_universe_instance sigma u in
- if u' == u then c else mkIndU (i, u')
- | Construct (co, u) when not (Univ.Instance.is_empty u) ->
- let u' = Evd.normalize_universe_instance sigma u in
- if u' == u then c else mkConstructU (co, u')
- | _ -> c
-
-let nf_evar =
- local_strong whd_evar
+let whd_evar = Evarutil.whd_evar
+let nf_evar = Evarutil.nf_evar
(* lazy reduction functions. The infos must be created for each term *)
(* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add
@@ -1213,16 +1191,16 @@ let nf_evar =
let clos_norm_flags flgs env sigma t =
try
let evars ev = safe_evar_value sigma ev in
- Closure.norm_val
- (Closure.create_clos_infos ~evars flgs env)
- (Closure.inject t)
+ CClosure.norm_val
+ (CClosure.create_clos_infos ~evars flgs env)
+ (CClosure.inject t)
with e when is_anomaly e -> error "Tried to normalize ill-typed term"
-let nf_beta = clos_norm_flags Closure.beta (Global.env ())
-let nf_betaiota = clos_norm_flags Closure.betaiota (Global.env ())
-let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta (Global.env ())
-let nf_betadeltaiota env sigma =
- clos_norm_flags Closure.betadeltaiota env sigma
+let nf_beta = clos_norm_flags CClosure.beta (Global.env ())
+let nf_betaiota = clos_norm_flags CClosure.betaiota (Global.env ())
+let nf_betaiotazeta = clos_norm_flags CClosure.betaiotazeta (Global.env ())
+let nf_all env sigma =
+ clos_norm_flags CClosure.all env sigma
(********************************************************************)
@@ -1253,31 +1231,29 @@ let pb_equal = function
let report_anomaly _ =
let e = UserError ("", Pp.str "Conversion test raised an anomaly") in
- let e = Errors.push e in
+ let e = CErrors.push e in
iraise e
-let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y =
+let test_trans_conversion (f: constr Reduction.extended_conversion_function) reds env sigma x y =
try
let evars ev = safe_evar_value sigma ev in
- let _ = f ~evars reds env (Evd.universes sigma) x y in
+ let _ = f ~reds env ~evars:(evars, Evd.universes sigma) x y in
true
with Reduction.NotConvertible -> false
| e when is_anomaly e -> report_anomaly e
-let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma
-let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma
-let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq
-
-let is_conv = is_trans_conv full_transparent_state
-let is_conv_leq = is_trans_conv_leq full_transparent_state
-let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv_leq
+let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv reds env sigma
+let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq reds env sigma
+let is_fconv ?(reds=full_transparent_state) = function
+ | Reduction.CONV -> is_conv ~reds
+ | Reduction.CUMUL -> is_conv_leq ~reds
let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y =
let f = match pb with
- | Reduction.CONV -> Reduction.trans_conv_universes
- | Reduction.CUMUL -> Reduction.trans_conv_leq_universes
+ | Reduction.CONV -> Reduction.conv
+ | Reduction.CUMUL -> Reduction.conv_leq
in
- try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true
+ try f ~reds:ts env ~evars:(safe_evar_value sigma, Evd.universes sigma) x y; true
with Reduction.NotConvertible -> false
| Univ.UniverseInconsistency _ -> false
| e when is_anomaly e -> report_anomaly e
@@ -1286,7 +1262,7 @@ let sigma_compare_sorts env pb s0 s1 sigma =
match pb with
| Reduction.CONV -> Evd.set_eq_sort env sigma s0 s1
| Reduction.CUMUL -> Evd.set_leq_sort env sigma s0 s1
-
+
let sigma_compare_instances ~flex i0 i1 sigma =
try Evd.set_eq_instances ~flex sigma i0 i1
with Evd.UniversesDiffer
@@ -1299,18 +1275,21 @@ let sigma_univ_state =
let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL)
?(ts=full_transparent_state) env sigma x y =
- try
+ try
+ let fold cstr sigma =
+ try Some (Evd.add_universe_constraints sigma cstr)
+ with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None
+ in
let b, sigma =
- let b, cstrs =
+ let ans =
if pb == Reduction.CUMUL then
- Universes.leq_constr_univs_infer (Evd.universes sigma) x y
+ Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y sigma
else
- Universes.eq_constr_univs_infer (Evd.universes sigma) x y
+ Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y sigma
in
- if b then
- try true, Evd.add_universe_constraints sigma cstrs
- with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> false, sigma
- else false, sigma
+ match ans with
+ | None -> false, sigma
+ | Some sigma -> true, sigma
in
if b then sigma, true
else
@@ -1416,7 +1395,7 @@ let instance sigma s c =
* error message. *)
let hnf_prod_app env sigma t n =
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ match kind_of_term (whd_all env sigma t) with
| Prod (_,_,b) -> subst1 n b
| _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product")
@@ -1427,7 +1406,7 @@ let hnf_prod_applist env sigma t nl =
List.fold_left (hnf_prod_app env sigma) t nl
let hnf_lam_app env sigma t n =
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ match kind_of_term (whd_all env sigma t) with
| Lambda (_,_,b) -> subst1 n b
| _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction")
@@ -1439,10 +1418,10 @@ let hnf_lam_applist env sigma t nl =
let splay_prod env sigma =
let rec decrec env m c =
- let t = whd_betadeltaiota env sigma c in
+ let t = whd_all env sigma c in
match kind_of_term t with
| Prod (n,a,c0) ->
- decrec (push_rel (n,None,a) env)
+ decrec (push_rel (LocalAssum (n,a)) env)
((n,a)::m) c0
| _ -> m,t
in
@@ -1450,10 +1429,10 @@ let splay_prod env sigma =
let splay_lam env sigma =
let rec decrec env m c =
- let t = whd_betadeltaiota env sigma c in
+ let t = whd_all env sigma c in
match kind_of_term t with
| Lambda (n,a,c0) ->
- decrec (push_rel (n,None,a) env)
+ decrec (push_rel (LocalAssum (n,a)) env)
((n,a)::m) c0
| _ -> m,t
in
@@ -1461,21 +1440,21 @@ let splay_lam env sigma =
let splay_prod_assum env sigma =
let rec prodec_rec env l c =
- let t = whd_betadeltaiota_nolet env sigma c in
+ let t = whd_allnolet env sigma c in
match kind_of_term t with
| Prod (x,t,c) ->
- prodec_rec (push_rel (x,None,t) env)
- (add_rel_decl (x, None, t) l) c
+ prodec_rec (push_rel (LocalAssum (x,t)) env)
+ (Context.Rel.add (LocalAssum (x,t)) l) c
| LetIn (x,b,t,c) ->
- prodec_rec (push_rel (x, Some b, t) env)
- (add_rel_decl (x, Some b, t) l) c
+ prodec_rec (push_rel (LocalDef (x,b,t)) env)
+ (Context.Rel.add (LocalDef (x,b,t)) l) c
| Cast (c,_,_) -> prodec_rec env l c
| _ ->
- let t' = whd_betadeltaiota env sigma t in
+ let t' = whd_all env sigma t in
if Term.eq_constr t t' then l,t
else prodec_rec env l t'
in
- prodec_rec env empty_rel_context
+ prodec_rec env Context.Rel.empty
let splay_arity env sigma c =
let l, c = splay_prod env sigma c in
@@ -1487,26 +1466,26 @@ let sort_of_arity env sigma c = snd (splay_arity env sigma c)
let splay_prod_n env sigma n =
let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else
- match kind_of_term (whd_betadeltaiota env sigma c) with
+ match kind_of_term (whd_all env sigma c) with
| Prod (n,a,c0) ->
- decrec (push_rel (n,None,a) env)
- (m-1) (add_rel_decl (n,None,a) ln) c0
+ decrec (push_rel (LocalAssum (n,a)) env)
+ (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0
| _ -> invalid_arg "splay_prod_n"
in
- decrec env n empty_rel_context
+ decrec env n Context.Rel.empty
let splay_lam_n env sigma n =
let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else
- match kind_of_term (whd_betadeltaiota env sigma c) with
+ match kind_of_term (whd_all env sigma c) with
| Lambda (n,a,c0) ->
- decrec (push_rel (n,None,a) env)
- (m-1) (add_rel_decl (n,None,a) ln) c0
+ decrec (push_rel (LocalAssum (n,a)) env)
+ (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0
| _ -> invalid_arg "splay_lam_n"
in
- decrec env n empty_rel_context
+ decrec env n Context.Rel.empty
let is_sort env sigma t =
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ match kind_of_term (whd_all env sigma t) with
| Sort s -> true
| _ -> false
@@ -1514,20 +1493,22 @@ let is_sort env sigma t =
of case/fix (heuristic used by evar_conv) *)
let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s =
+ let refold = get_refolding_in_reduction () in
+ let tactic_mode = false in
let rec whrec csts s =
- let (t, stack as s),csts' = whd_state_gen ~csts false betaiota env sigma s in
+ let (t, stack as s),csts' = whd_state_gen ~csts ~refold ~tactic_mode CClosure.betaiota env sigma s in
match Stack.strip_app stack with
|args, (Stack.Case _ :: _ as stack') ->
- let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false
- (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in
+ let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode
+ (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in
if reducible_mind_case t_o then whrec csts_o (t_o, stack_o@stack') else s,csts'
|args, (Stack.Fix _ :: _ as stack') ->
- let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false
- (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in
+ let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode
+ (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in
if isConstruct t_o then whrec csts_o (t_o, stack_o@stack') else s,csts'
|args, (Stack.Proj (n,m,p,_) :: stack'') ->
- let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false
- (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in
+ let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode
+ (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in
if isConstruct t_o then
whrec Cst_stack.empty (Stack.nth stack_o (n+m), stack'')
else s,csts'
@@ -1536,10 +1517,10 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s =
let find_conclusion env sigma =
let rec decrec env c =
- let t = whd_betadeltaiota env sigma c in
+ let t = whd_all env sigma c in
match kind_of_term t with
- | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
- | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
+ | Prod (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0
+ | Lambda (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0
| t -> t
in
decrec env
@@ -1623,7 +1604,7 @@ let meta_reducible_instance evd b =
with
| Some g -> irec (mkProj (p,g))
| None -> mkProj (p,c))
- | _ -> map_constr irec u
+ | _ -> Constr.map irec u
in
if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus
else irec b.rebus
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index aea0a9ae..4cd7a2a8 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -8,7 +8,6 @@
open Names
open Term
-open Context
open Univ
open Evd
open Environ
@@ -29,6 +28,11 @@ module ReductionBehaviour : sig
val print : Globnames.global_reference -> Pp.std_ppcmds
end
+(** Option telling if reduction should use the refolding machinery of cbn
+ (off by default) *)
+val get_refolding_in_reduction : unit -> bool
+val set_refolding_in_reduction : bool -> unit
+
(** {6 Machinery about a stack of unfolded constant }
cst applied to params must convertible to term of the state applied to args
@@ -109,7 +113,7 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr
type reduction_function = contextual_reduction_function
type local_reduction_function = evar_map -> constr -> constr
-type e_reduction_function = env -> evar_map -> constr -> evar_map * constr
+type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma }
type contextual_stack_reduction_function =
env -> evar_map -> constr -> constr * constr list
@@ -135,21 +139,21 @@ val stack_reduction_of_reduction :
i*)
val stacklam : (state -> 'a) -> constr list -> constr -> constr Stack.t -> 'a
-val whd_state_gen : ?csts:Cst_stack.t -> bool -> Closure.RedFlags.reds ->
- Environ.env -> Evd.evar_map -> state -> state * Cst_stack.t
+val whd_state_gen : ?csts:Cst_stack.t -> refold:bool -> tactic_mode:bool ->
+ CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> state -> state * Cst_stack.t
-val iterate_whd_gen : bool -> Closure.RedFlags.reds ->
+val iterate_whd_gen : bool -> CClosure.RedFlags.reds ->
Environ.env -> Evd.evar_map -> Term.constr -> Term.constr
(** {6 Generic Optimized Reduction Function using Closures } *)
-val clos_norm_flags : Closure.RedFlags.reds -> reduction_function
+val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function
(** Same as [(strong whd_beta[delta][iota])], but much faster on big terms *)
val nf_beta : local_reduction_function
val nf_betaiota : local_reduction_function
val nf_betaiotazeta : local_reduction_function
-val nf_betadeltaiota : reduction_function
+val nf_all : reduction_function
val nf_evar : evar_map -> constr -> constr
(** Lazy strategy, weak head reduction *)
@@ -159,9 +163,8 @@ val whd_nored : local_reduction_function
val whd_beta : local_reduction_function
val whd_betaiota : local_reduction_function
val whd_betaiotazeta : local_reduction_function
-val whd_betadeltaiota : contextual_reduction_function
-val whd_betadeltaiota_nolet : contextual_reduction_function
-val whd_betaetalet : local_reduction_function
+val whd_all : contextual_reduction_function
+val whd_allnolet : contextual_reduction_function
val whd_betalet : local_reduction_function
(** Removes cast and put into applicative form *)
@@ -169,18 +172,16 @@ val whd_nored_stack : local_stack_reduction_function
val whd_beta_stack : local_stack_reduction_function
val whd_betaiota_stack : local_stack_reduction_function
val whd_betaiotazeta_stack : local_stack_reduction_function
-val whd_betadeltaiota_stack : contextual_stack_reduction_function
-val whd_betadeltaiota_nolet_stack : contextual_stack_reduction_function
-val whd_betaetalet_stack : local_stack_reduction_function
+val whd_all_stack : contextual_stack_reduction_function
+val whd_allnolet_stack : contextual_stack_reduction_function
val whd_betalet_stack : local_stack_reduction_function
val whd_nored_state : local_state_reduction_function
val whd_beta_state : local_state_reduction_function
val whd_betaiota_state : local_state_reduction_function
val whd_betaiotazeta_state : local_state_reduction_function
-val whd_betadeltaiota_state : contextual_state_reduction_function
-val whd_betadeltaiota_nolet_state : contextual_state_reduction_function
-val whd_betaetalet_state : local_state_reduction_function
+val whd_all_state : contextual_state_reduction_function
+val whd_allnolet_state : contextual_state_reduction_function
val whd_betalet_state : local_state_reduction_function
(** {6 Head normal forms } *)
@@ -188,18 +189,14 @@ val whd_betalet_state : local_state_reduction_function
val whd_delta_stack : stack_reduction_function
val whd_delta_state : state_reduction_function
val whd_delta : reduction_function
-val whd_betadelta_stack : stack_reduction_function
-val whd_betadelta_state : state_reduction_function
-val whd_betadelta : reduction_function
-val whd_betadeltaeta_stack : stack_reduction_function
-val whd_betadeltaeta_state : state_reduction_function
-val whd_betadeltaeta : reduction_function
-val whd_betadeltaiotaeta_stack : stack_reduction_function
-val whd_betadeltaiotaeta_state : state_reduction_function
-val whd_betadeltaiotaeta : reduction_function
-
-val whd_eta : constr -> constr
-val whd_zeta : constr -> constr
+val whd_betadeltazeta_stack : stack_reduction_function
+val whd_betadeltazeta_state : state_reduction_function
+val whd_betadeltazeta : reduction_function
+val whd_zeta_stack : local_stack_reduction_function
+val whd_zeta_state : local_state_reduction_function
+val whd_zeta : local_reduction_function
+
+val shrink_eta : constr -> constr
(** Various reduction functions *)
@@ -218,11 +215,10 @@ val splay_prod : env -> evar_map -> constr -> (Name.t * constr) list * constr
val splay_lam : env -> evar_map -> constr -> (Name.t * constr) list * constr
val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * sorts
val sort_of_arity : env -> evar_map -> constr -> sorts
-val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr
-val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr
+val splay_prod_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr
+val splay_lam_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr
val splay_prod_assum :
- env -> evar_map -> constr -> rel_context * constr
-val is_sort : env -> evar_map -> types -> bool
+ env -> evar_map -> constr -> Context.Rel.t * constr
type 'a miota_args = {
mP : constr; (** the result type *)
@@ -251,13 +247,9 @@ type conversion_test = constraints -> constraints
val pb_is_equal : conv_pb -> bool
val pb_equal : conv_pb -> conv_pb
-val is_conv : env -> evar_map -> constr -> constr -> bool
-val is_conv_leq : env -> evar_map -> constr -> constr -> bool
-val is_fconv : conv_pb -> env -> evar_map -> constr -> constr -> bool
-
-val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> bool
-val is_trans_conv_leq : transparent_state -> env -> evar_map -> constr -> constr -> bool
-val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr -> constr -> bool
+val is_conv : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool
+val is_conv_leq : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool
+val is_fconv : ?reds:transparent_state -> conv_pb -> env -> evar_map -> constr -> constr -> bool
(** [check_conv] Checks universe constraints only.
pb defaults to CUMUL and ts to a full transparent state.
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index cb4e588e..98b36fb9 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Term
open Vars
@@ -18,6 +18,7 @@ open Reductionops
open Environ
open Termops
open Arguments_renaming
+open Context.Rel.Declaration
type retype_error =
| NotASort
@@ -61,7 +62,7 @@ let get_type_from_constraints env sigma t =
let rec subst_type env sigma typ = function
| [] -> typ
| h::rest ->
- match kind_of_term (whd_betadeltaiota env sigma typ) with
+ match kind_of_term (whd_all env sigma typ) with
| Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest
| _ -> retype_error NonFunctionalConstruction
@@ -70,29 +71,30 @@ let rec subst_type env sigma typ = function
let sort_of_atomic_type env sigma ft args =
let rec concl_of_arity env n ar args =
- match kind_of_term (whd_betadeltaiota env sigma ar), args with
- | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some (lift n h),t) env) (n + 1) b l
+ match kind_of_term (whd_all env sigma ar), args with
+ | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l
| Sort s, [] -> s
| _ -> retype_error NotASort
in concl_of_arity env 0 ft (Array.to_list args)
let type_of_var env id =
- try let (_,_,ty) = lookup_named id env in ty
+ let open Context.Named.Declaration in
+ try get_type (lookup_named id env)
with Not_found -> retype_error (BadVariable id)
let decomp_sort env sigma t =
- match kind_of_term (whd_betadeltaiota env sigma t) with
+ match kind_of_term (whd_all env sigma t) with
| Sort s -> s
| _ -> retype_error NotASort
let retype ?(polyprop=true) sigma =
- let rec type_of env cstr=
+ let rec type_of env cstr =
match kind_of_term cstr with
| Meta n ->
(try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus
with Not_found -> retype_error (BadMeta n))
| Rel n ->
- let (_,_,ty) = lookup_rel n env in
+ let ty = get_type (lookup_rel n env) in
lift n ty
| Var id -> type_of_var env id
| Const cst -> rename_type_of_constant env cst
@@ -111,13 +113,13 @@ let retype ?(polyprop=true) sigma =
in
let n = inductive_nrealdecls_env env (fst (fst (dest_ind_family indf))) in
let t = betazetaevar_applist sigma n p realargs in
- (match kind_of_term (whd_betadeltaiota env sigma (type_of env t)) with
+ (match kind_of_term (whd_all env sigma (type_of env t)) with
| Prod _ -> whd_beta sigma (applist (t, [c]))
| _ -> t)
| Lambda (name,c1,c2) ->
- mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2)
+ mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2)
| LetIn (name,b,c1,c2) ->
- subst1 b (type_of (push_rel (name,Some b,c1) env) c2)
+ subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2)
| Fix ((_,i),(_,tys,_)) -> tys.(i)
| CoFix (i,(_,tys,_)) -> tys.(i)
| App(f,args) when is_template_polymorphic env f ->
@@ -140,7 +142,7 @@ let retype ?(polyprop=true) sigma =
| Sort (Prop c) -> type1_sort
| Sort (Type u) -> Type (Univ.super u)
| Prod (name,t,c2) ->
- (match (sort_of env t, sort_of (push_rel (name,None,t) env) c2) with
+ (match (sort_of env t, sort_of (push_rel (LocalAssum (name,t)) env) c2) with
| _, (Prop Null as s) -> s
| Prop _, (Prop Pos as s) -> s
| Type _, (Prop Pos as s) when is_impredicative_set env -> s
@@ -161,7 +163,7 @@ let retype ?(polyprop=true) sigma =
| Sort (Prop c) -> InType
| Sort (Type u) -> InType
| Prod (name,t,c2) ->
- let s2 = sort_family_of (push_rel (name,None,t) env) c2 in
+ 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 f ->
@@ -235,9 +237,9 @@ let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c }
let sorts_of_context env evc ctxt =
let rec aux = function
| [] -> env,[]
- | (_,_,t as d)::ctxt ->
+ | d :: ctxt ->
let env,sorts = aux ctxt in
- let s = get_sort_of env evc t in
+ let s = get_sort_of env evc (get_type d) in
(push_rel d env,s::sorts) in
snd (aux ctxt)
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index 37cec0c6..8ca40f82 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -8,7 +8,6 @@
open Term
open Evd
-open Context
open Environ
(** This family of functions assumes its constr argument is known to be
@@ -44,6 +43,8 @@ val type_of_global_reference_knowing_parameters : env -> evar_map -> constr ->
val type_of_global_reference_knowing_conclusion :
env -> evar_map -> constr -> types -> evar_map * types
-val sorts_of_context : env -> evar_map -> rel_context -> sorts list
+val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list
val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr
+
+val print_retype_error : retype_error -> Pp.std_ppcmds
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 7c4f28ca..820a81b5 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -18,11 +18,12 @@ open Termops
open Find_subterm
open Namegen
open Environ
-open Closure
+open CClosure
open Reductionops
open Cbv
open Patternops
open Locus
+open Sigma.Notations
(* Errors *)
@@ -53,12 +54,13 @@ let is_evaluable env = function
| EvalVarRef id -> is_evaluable_var env id
let value_of_evaluable_ref env evref u =
+ let open Context.Named.Declaration in
match evref with
| EvalConstRef con ->
(try constant_value_in env (con,u)
with NotEvaluableConst IsProj ->
raise (Invalid_argument "value_of_evaluable_ref"))
- | EvalVarRef id -> Option.get (pi2 (lookup_named id env))
+ | EvalVarRef id -> lookup_named id env |> get_value |> Option.get
let evaluable_of_global_reference env = function
| ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst
@@ -103,29 +105,29 @@ let destEvalRefU c = match kind_of_term c with
| Evar ev -> (EvalEvar ev, Univ.Instance.empty)
| _ -> anomaly (Pp.str "Not an unfoldable reference")
-let unsafe_reference_opt_value env sigma eval =
+let unsafe_reference_opt_value env sigma eval =
match eval with
| EvalConst cst ->
(match (lookup_constant cst env).Declarations.const_body with
| Declarations.Def c -> Some (Mod_subst.force_constr c)
| _ -> None)
| EvalVar id ->
- let (_,v,_) = lookup_named id env in
- v
+ let open Context.Named.Declaration in
+ lookup_named id env |> get_value
| EvalRel n ->
- let (_,v,_) = lookup_rel n env in
- Option.map (lift n) v
+ let open Context.Rel.Declaration in
+ lookup_rel n env |> map_value (lift n) |> get_value
| EvalEvar ev -> Evd.existential_opt_value sigma ev
let reference_opt_value env sigma eval u =
match eval with
| EvalConst cst -> constant_opt_value_in env (cst,u)
| EvalVar id ->
- let (_,v,_) = lookup_named id env in
- v
+ let open Context.Named.Declaration in
+ lookup_named id env |> get_value
| EvalRel n ->
- let (_,v,_) = lookup_rel n env in
- Option.map (lift n) v
+ let open Context.Rel.Declaration in
+ lookup_rel n env |> map_value (lift n) |> get_value
| EvalEvar ev -> Evd.existential_opt_value sigma ev
exception NotEvaluable
@@ -255,10 +257,11 @@ let invert_name labs l na0 env sigma ref = function
let compute_consteval_direct env sigma ref =
let rec srec env n labs onlyproj c =
- let c',l = whd_betadelta_stack env sigma c in
+ let c',l = whd_betadeltazeta_stack env sigma c in
match kind_of_term c' with
| Lambda (id,t,g) when List.is_empty l && not onlyproj ->
- srec (push_rel (id,None,t) env) (n+1) (t::labs) onlyproj g
+ let open Context.Rel.Declaration in
+ srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g
| Fix fix when not onlyproj ->
(try check_fix_reversibility labs l fix
with Elimconst -> NotAnElimination)
@@ -277,7 +280,8 @@ let compute_consteval_mutual_fix env sigma ref =
let nargs = List.length l in
match kind_of_term c' with
| Lambda (na,t,g) when List.is_empty l ->
- srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g
+ let open Context.Rel.Declaration in
+ srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g
| Fix ((lv,i),(names,_,_)) ->
(* Last known constant wrapping Fix is ref = [labs](Fix l) *)
(match compute_consteval_direct env sigma ref with
@@ -371,7 +375,8 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs =
let dummy = mkProp
let vfx = Id.of_string "_expanded_fix_"
let vfun = Id.of_string "_eliminator_function_"
-let venv = val_of_named_context [(vfx, None, dummy); (vfun, None, dummy)]
+let venv = let open Context.Named.Declaration in
+ val_of_named_context [LocalAssum (vfx, dummy); LocalAssum (vfun, dummy)]
(* Mark every occurrence of substituted vars (associated to a function)
as a problem variable: an evar that can be instantiated either by
@@ -385,7 +390,9 @@ let substl_with_function subst sigma constr =
if i <= k + Array.length v then
match v.(i-k-1) with
| (fx, Some (min, ref)) ->
- let (sigma, evk) = Evarutil.new_pure_evar venv !evd dummy in
+ let sigma = Sigma.Unsafe.of_evar_map !evd in
+ let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in
+ let sigma = Sigma.to_evar_map sigma in
evd := sigma;
minargs := Evar.Map.add evk min !minargs;
lift k (mkEvar (evk, [|fx;ref|]))
@@ -534,9 +541,11 @@ let match_eval_ref_value env sigma constr =
| Const (sp, u) when is_evaluable env (EvalConstRef sp) ->
Some (constant_value_in env (sp, u))
| Var id when is_evaluable env (EvalVarRef id) ->
- let (_,v,_) = lookup_named id env in v
- | Rel n -> let (_,v,_) = lookup_rel n env in
- Option.map (lift n) v
+ let open Context.Named.Declaration in
+ lookup_named id env |> get_value
+ | Rel n ->
+ let open Context.Rel.Declaration in
+ lookup_rel n env |> map_value (lift n) |> get_value
| Evar ev -> Evd.existential_opt_value sigma ev
| _ -> None
@@ -601,12 +610,14 @@ let whd_nothing_for_iota env sigma s =
let rec whrec (x, stack as s) =
match kind_of_term x with
| Rel n ->
+ let open Context.Rel.Declaration in
(match lookup_rel n env with
- | (_,Some body,_) -> whrec (lift n body, stack)
+ | LocalDef (_,body,_) -> whrec (lift n body, stack)
| _ -> s)
| Var id ->
+ let open Context.Named.Declaration in
(match lookup_named id env with
- | (_,Some body,_) -> whrec (body, stack)
+ | LocalDef (_,body,_) -> whrec (body, stack)
| _ -> s)
| Evar ev ->
(try whrec (Evd.existential_value sigma ev, stack)
@@ -809,7 +820,9 @@ let try_red_product env sigma c =
simpfun (Stack.zip (f,stack')))
| _ -> simpfun (appvect (redrec env f, l)))
| Cast (c,_,_) -> redrec env c
- | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b)
+ | Prod (x,a,b) ->
+ let open Context.Rel.Declaration in
+ mkProd (x, a, redrec (push_rel (LocalAssum (x,a)) env) b)
| LetIn (x,a,b,t) -> redrec env (subst1 a t)
| Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf))
| Proj (p, c) ->
@@ -857,7 +870,7 @@ let red_product env sigma c =
*)
let whd_simpl_orelse_delta_but_fix_old env sigma c =
- let whd_all = whd_betadeltaiota_state env sigma in
+ let whd_all = whd_all_state env sigma in
let rec redrec (x, stack as s) =
match kind_of_term x with
| Lambda (na,t,c) ->
@@ -940,8 +953,6 @@ let matches_head env sigma c t =
| Proj (p, _) -> Constr_matching.matches env sigma c (mkConst (Projection.constant p))
| _ -> raise Constr_matching.PatternMatchingFailure
-let is_pattern_meta = function Pattern.PMeta _ -> true | _ -> false
-
(** FIXME: Specific function to handle projections: it ignores what happens on the
parameters. This is a temporary fix while rewrite etc... are not up to equivalence
of the projection and its eta expanded form.
@@ -962,10 +973,12 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c =
| _ -> mkApp (app', [| a' |]))
| _ -> map_constr_with_binders_left_to_right g f acc c
-let e_contextually byhead (occs,c) f env sigma t =
+let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t ->
let (nowhere_except_in,locs) = Locusops.convert_occs occs in
let maxocc = List.fold_right max locs 0 in
let pos = ref 1 in
+ let sigma = Sigma.to_evar_map sigma in
+ (** FIXME: we do suspicious things with this evarmap *)
let evd = ref sigma in
let rec traverse nested (env,c as envc) t =
if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t
@@ -984,8 +997,8 @@ let e_contextually byhead (occs,c) f env sigma t =
(* Skip inner occurrences for stable counting of occurrences *)
if locs != [] then
ignore (traverse_below (Some (!pos-1)) envc t);
- let evm, t = f subst env !evd t in
- (evd := evm; t)
+ let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in
+ (evd := Sigma.to_evar_map evm; t)
end
else
traverse_below nested envc t
@@ -1004,11 +1017,15 @@ let e_contextually byhead (occs,c) f env sigma t =
in
let t' = traverse None (env,c) t in
if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs;
- !evd, t'
+ Sigma.Unsafe.of_pair (t', !evd)
+ end }
let contextually byhead occs f env sigma t =
- let f' subst env sigma t = sigma, f subst env sigma t in
- snd (e_contextually byhead occs f' env sigma t)
+ let f' subst = { e_redfun = begin fun env sigma t ->
+ Sigma.here (f subst env (Sigma.to_evar_map sigma) t) sigma
+ end } in
+ let Sigma (c, _, _) = (e_contextually byhead occs f').e_redfun env (Sigma.Unsafe.of_evar_map sigma) t in
+ c
(* linear bindings (following pretty-printer) of the value of name in c.
* n is the number of the next occurrence of name.
@@ -1055,10 +1072,6 @@ let unfold env sigma name =
else
error (string_of_evaluable_ref env name^" is opaque.")
-let is_projection env = function
- | EvalVarRef _ -> false
- | EvalConstRef c -> Environ.is_projection c env
-
(* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)]
* Unfolds the constant name in a term c following a list of occurrences occl.
* at the occurrences of occ_list. If occ_list is empty, unfold all occurrences.
@@ -1112,7 +1125,7 @@ let cbv_norm_flags flags env sigma t =
let cbv_beta = cbv_norm_flags beta empty_env
let cbv_betaiota = cbv_norm_flags betaiota empty_env
-let cbv_betadeltaiota env sigma = cbv_norm_flags betadeltaiota env sigma
+let cbv_betadeltaiota env sigma = cbv_norm_flags all env sigma
let compute = cbv_betadeltaiota
@@ -1131,13 +1144,15 @@ let abstract_scheme env (locc,a) (c, sigma) =
let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in
mkLambda (na,ta,c'), sigma'
-let pattern_occs loccs_trm env sigma c =
+let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c ->
+ let sigma = Sigma.to_evar_map sigma in
let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (c,sigma) in
try
let _ = Typing.unsafe_type_of env sigma abstr_trm in
- sigma, applist(abstr_trm, List.map snd loccs_trm)
+ Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma)
with Type_errors.TypeError (env',t) ->
raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t))))
+ end }
(* Used in several tactics. *)
@@ -1163,14 +1178,15 @@ let reduce_to_ind_gen allow_product env sigma t =
match kind_of_term (fst (decompose_app t)) with
| Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l)
| Prod (n,ty,t') ->
+ let open Context.Rel.Declaration in
if allow_product then
- elimrec (push_rel (n,None,ty) env) t' ((n,None,ty)::l)
+ elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l)
else
errorlabstrm "" (str"Not an inductive definition.")
| _ ->
(* Last chance: we allow to bypass the Opaque flag (as it
was partially the case between V5.10 and V8.1 *)
- let t' = whd_betadeltaiota env sigma t in
+ let t' = whd_all env sigma t in
match kind_of_term (fst (decompose_app t')) with
| Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l)
| _ -> errorlabstrm "" (str"Not an inductive product.")
@@ -1241,7 +1257,8 @@ let reduce_to_ref_gen allow_product env sigma ref t =
match kind_of_term c with
| Prod (n,ty,t') ->
if allow_product then
- elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l)
+ let open Context.Rel.Declaration in
+ elimrec (push_rel (LocalAssum (n,t)) env) t' ((LocalAssum (n,ty))::l)
else
error_cannot_recognize ref
| _ ->
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index 6a7248e1..f8dfe1ad 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -61,13 +61,12 @@ val unfoldn :
val fold_commands : constr list -> reduction_function
(** Pattern *)
-val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr ->
- evar_map * constr
+val pattern_occs : (occurrences * constr) list -> e_reduction_function
(** Rem: Lazy strategies are defined in Reduction *)
(** Call by value strategy (uses Closures) *)
-val cbv_norm_flags : Closure.RedFlags.reds -> reduction_function
+val cbv_norm_flags : CClosure.RedFlags.reds -> reduction_function
val cbv_beta : local_reduction_function
val cbv_betaiota : local_reduction_function
val cbv_betadeltaiota : reduction_function
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
deleted file mode 100644
index 9d469cb7..00000000
--- a/pretyping/termops.ml
+++ /dev/null
@@ -1,1026 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Errors
-open Util
-open Names
-open Nameops
-open Term
-open Vars
-open Context
-open Environ
-
-(* Sorts and sort family *)
-
-let print_sort = function
- | Prop Pos -> (str "Set")
- | Prop Null -> (str "Prop")
- | Type u -> (str "Type(" ++ Univ.Universe.pr u ++ str ")")
-
-let pr_sort_family = function
- | InSet -> (str "Set")
- | InProp -> (str "Prop")
- | InType -> (str "Type")
-
-let pr_name = function
- | Name id -> pr_id id
- | Anonymous -> str "_"
-
-let pr_con sp = str(string_of_con sp)
-
-let pr_fix pr_constr ((t,i),(lna,tl,bl)) =
- let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in
- hov 1
- (str"fix " ++ int i ++ spc() ++ str"{" ++
- v 0 (prlist_with_sep spc (fun (na,i,ty,bd) ->
- pr_name na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++
- cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
- str"}")
-
-let pr_puniverses p u =
- if Univ.Instance.is_empty u then p
- else p ++ str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)"
-
-let rec pr_constr c = match kind_of_term c with
- | Rel n -> str "#"++int n
- | Meta n -> str "Meta(" ++ int n ++ str ")"
- | Var id -> pr_id id
- | Sort s -> print_sort s
- | Cast (c,_, t) -> hov 1
- (str"(" ++ pr_constr c ++ cut() ++
- str":" ++ pr_constr t ++ str")")
- | Prod (Name(id),t,c) -> hov 1
- (str"forall " ++ pr_id id ++ str":" ++ pr_constr t ++ str"," ++
- spc() ++ pr_constr c)
- | Prod (Anonymous,t,c) -> hov 0
- (str"(" ++ pr_constr t ++ str " ->" ++ spc() ++
- pr_constr c ++ str")")
- | Lambda (na,t,c) -> hov 1
- (str"fun " ++ pr_name na ++ str":" ++
- pr_constr t ++ str" =>" ++ spc() ++ pr_constr c)
- | LetIn (na,b,t,c) -> hov 0
- (str"let " ++ pr_name na ++ str":=" ++ pr_constr b ++
- str":" ++ brk(1,2) ++ pr_constr t ++ cut() ++
- pr_constr c)
- | App (c,l) -> hov 1
- (str"(" ++ pr_constr c ++ spc() ++
- prlist_with_sep spc pr_constr (Array.to_list l) ++ str")")
- | Evar (e,l) -> hov 1
- (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++
- prlist_with_sep spc pr_constr (Array.to_list l) ++str"}")
- | Const (c,u) -> str"Cst(" ++ pr_puniverses (pr_con c) u ++ str")"
- | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i) u ++ str")"
- | Construct (((sp,i),j),u) ->
- str"Constr(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")"
- | Proj (p,c) -> str"Proj(" ++ pr_con (Projection.constant p) ++ str"," ++ bool (Projection.unfolded p) ++ pr_constr c ++ str")"
- | Case (ci,p,c,bl) -> v 0
- (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++
- pr_constr c ++ str"of") ++ cut() ++
- prlist_with_sep (fun _ -> brk(1,2)) pr_constr (Array.to_list bl) ++
- cut() ++ str"end")
- | Fix f -> pr_fix pr_constr f
- | CoFix(i,(lna,tl,bl)) ->
- let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in
- hov 1
- (str"cofix " ++ int i ++ spc() ++ str"{" ++
- v 0 (prlist_with_sep spc (fun (na,ty,bd) ->
- pr_name na ++ str":" ++ pr_constr ty ++
- cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
- str"}")
-
-let term_printer = ref (fun _ -> pr_constr)
-let print_constr_env t = !term_printer t
-let print_constr t = !term_printer (Global.env()) t
-let set_print_constr f = term_printer := f
-
-let pr_var_decl env (id,c,typ) =
- let pbody = match c with
- | None -> (mt ())
- | Some c ->
- (* Force evaluation *)
- let pb = print_constr_env env c in
- (str" := " ++ pb ++ cut () ) in
- let pt = print_constr_env env typ in
- let ptyp = (str" : " ++ pt) in
- (pr_id id ++ hov 0 (pbody ++ ptyp))
-
-let pr_rel_decl env (na,c,typ) =
- let pbody = match c with
- | None -> mt ()
- | Some c ->
- (* Force evaluation *)
- let pb = print_constr_env env c in
- (str":=" ++ spc () ++ pb ++ spc ()) in
- let ptyp = print_constr_env env typ in
- match na with
- | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
- | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
-
-let print_named_context env =
- hv 0 (fold_named_context
- (fun env d pps ->
- pps ++ ws 2 ++ pr_var_decl env d)
- env ~init:(mt ()))
-
-let print_rel_context env =
- hv 0 (fold_rel_context
- (fun env d pps -> pps ++ ws 2 ++ pr_rel_decl env d)
- env ~init:(mt ()))
-
-let print_env env =
- let sign_env =
- fold_named_context
- (fun env d pps ->
- let pidt = pr_var_decl env d in
- (pps ++ fnl () ++ pidt))
- env ~init:(mt ())
- in
- let db_env =
- fold_rel_context
- (fun env d pps ->
- let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat))
- env ~init:(mt ())
- in
- (sign_env ++ db_env)
-
-(* [Rel (n+m);...;Rel(n+1)] *)
-let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i))
-
-let rel_list n m =
- let rec reln l p =
- if p>m then l else reln (mkRel(n+p)::l) (p+1)
- in
- reln [] 1
-
-(* Same as [rel_list] but takes a context as argument and skips let-ins *)
-let extended_rel_list n hyps =
- let rec reln l p = function
- | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps
- | (_,Some _,_) :: hyps -> reln l (p+1) hyps
- | [] -> l
- in
- reln [] 1 hyps
-
-let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps)
-
-
-
-let push_rel_assum (x,t) env = push_rel (x,None,t) env
-
-let push_rels_assum assums =
- push_rel_context (List.map (fun (x,t) -> (x,None,t)) assums)
-
-let push_named_rec_types (lna,typarray,_) env =
- let ctxt =
- Array.map2_i
- (fun i na t ->
- match na with
- | Name id -> (id, None, lift i t)
- | Anonymous -> anomaly (Pp.str "Fix declarations must be named"))
- lna typarray in
- Array.fold_left
- (fun e assum -> push_named assum e) env ctxt
-
-let lookup_rel_id id sign =
- let rec lookrec n = function
- | [] -> raise Not_found
- | (Anonymous, _, _) :: l -> lookrec (n + 1) l
- | (Name id', b, t) :: l ->
- if Names.Id.equal id' id then (n, b, t) else lookrec (n + 1) l
- in
- lookrec 1 sign
-
-(* Constructs either [forall x:t, c] or [let x:=b:t in c] *)
-let mkProd_or_LetIn (na,body,t) c =
- match body with
- | None -> mkProd (na, t, c)
- | Some b -> mkLetIn (na, b, t, c)
-
-(* Constructs either [forall x:t, c] or [c] in which [x] is replaced by [b] *)
-let mkProd_wo_LetIn (na,body,t) c =
- match body with
- | None -> mkProd (na, t, c)
- | Some b -> subst1 b c
-
-let it_mkProd init = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) init
-let it_mkLambda init = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) init
-
-let it_named_context_quantifier f ~init =
- List.fold_left (fun c d -> f d c) init
-
-let it_mkProd_or_LetIn init = it_named_context_quantifier mkProd_or_LetIn ~init
-let it_mkProd_wo_LetIn init = it_named_context_quantifier mkProd_wo_LetIn ~init
-let it_mkLambda_or_LetIn init = it_named_context_quantifier mkLambda_or_LetIn ~init
-let it_mkNamedProd_or_LetIn init = it_named_context_quantifier mkNamedProd_or_LetIn ~init
-let it_mkNamedProd_wo_LetIn init = it_named_context_quantifier mkNamedProd_wo_LetIn ~init
-let it_mkNamedLambda_or_LetIn init = it_named_context_quantifier mkNamedLambda_or_LetIn ~init
-
-let it_mkLambda_or_LetIn_from_no_LetIn c decls =
- let rec aux k decls c = match decls with
- | [] -> c
- | (na,Some b,t)::decls -> mkLetIn (na,b,t,aux (k-1) decls (liftn 1 k c))
- | (na,None,t)::decls -> mkLambda (na,t,aux (k-1) decls c)
- in aux (List.length decls) (List.rev decls) c
-
-(* *)
-
-(* strips head casts and flattens head applications *)
-let rec strip_head_cast c = match kind_of_term c with
- | App (f,cl) ->
- let rec collapse_rec f cl2 = match kind_of_term f with
- | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
- | Cast (c,_,_) -> collapse_rec c cl2
- | _ -> if Int.equal (Array.length cl2) 0 then f else mkApp (f,cl2)
- in
- collapse_rec f cl
- | Cast (c,_,_) -> strip_head_cast c
- | _ -> c
-
-let rec drop_extra_implicit_args c = match kind_of_term c with
- (* Removed trailing extra implicit arguments, what improves compatibility
- for constants with recently added maximal implicit arguments *)
- | App (f,args) when isEvar (Array.last args) ->
- drop_extra_implicit_args
- (mkApp (f,fst (Array.chop (Array.length args - 1) args)))
- | _ -> c
-
-(* Get the last arg of an application *)
-let last_arg c = match kind_of_term c with
- | App (f,cl) -> Array.last cl
- | _ -> anomaly (Pp.str "last_arg")
-
-(* Get the last arg of an application *)
-let decompose_app_vect c =
- match kind_of_term c with
- | App (f,cl) -> (f, cl)
- | _ -> (c,[||])
-
-let adjust_app_list_size f1 l1 f2 l2 =
- let len1 = List.length l1 and len2 = List.length l2 in
- if Int.equal len1 len2 then (f1,l1,f2,l2)
- else if len1 < len2 then
- let extras,restl2 = List.chop (len2-len1) l2 in
- (f1, l1, applist (f2,extras), restl2)
- else
- let extras,restl1 = List.chop (len1-len2) l1 in
- (applist (f1,extras), restl1, f2, l2)
-
-let adjust_app_array_size f1 l1 f2 l2 =
- let len1 = Array.length l1 and len2 = Array.length l2 in
- if Int.equal len1 len2 then (f1,l1,f2,l2)
- else if len1 < len2 then
- let extras,restl2 = Array.chop (len2-len1) l2 in
- (f1, l1, appvect (f2,extras), restl2)
- else
- let extras,restl1 = Array.chop (len1-len2) l1 in
- (appvect (f1,extras), restl1, f2, l2)
-
-(* [map_constr_with_named_binders g f l c] maps [f l] on the immediate
- subterms of [c]; it carries an extra data [l] (typically a name
- list) which is processed by [g na] (which typically cons [na] to
- [l]) at each binder traversal (with name [na]); it is not recursive
- and the order with which subterms are processed is not specified *)
-
-let map_constr_with_named_binders g f l c = match kind_of_term c with
- | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
- | Construct _) -> c
- | Cast (c,k,t) -> mkCast (f l c, k, f l t)
- | Prod (na,t,c) -> mkProd (na, f l t, f (g na l) c)
- | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c)
- | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c)
- | App (c,al) -> mkApp (f l c, Array.map (f l) al)
- | Proj (p,c) -> mkProj (p, f l c)
- | Evar (e,al) -> mkEvar (e, Array.map (f l) al)
- | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl)
- | Fix (ln,(lna,tl,bl)) ->
- let l' = Array.fold_left (fun l na -> g na l) l lna in
- mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
- | CoFix(ln,(lna,tl,bl)) ->
- let l' = Array.fold_left (fun l na -> g na l) l lna in
- mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
-
-(* [map_constr_with_binders_left_to_right g f n c] maps [f n] on the
- immediate subterms of [c]; it carries an extra data [n] (typically
- a lift index) which is processed by [g] (which typically add 1 to
- [n]) at each binder traversal; the subterms are processed from left
- to right according to the usual representation of the constructions
- (this may matter if [f] does a side-effect); it is not recursive;
- in fact, the usual representation of the constructions is at the
- time being almost those of the ML representation (except for
- (co-)fixpoint) *)
-
-let fold_rec_types g (lna,typarray,_) e =
- let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in
- Array.fold_left (fun e assum -> g assum e) e ctxt
-
-let map_left2 f a g b =
- let l = Array.length a in
- if Int.equal l 0 then [||], [||] else begin
- let r = Array.make l (f a.(0)) in
- let s = Array.make l (g b.(0)) in
- for i = 1 to l - 1 do
- r.(i) <- f a.(i);
- s.(i) <- g b.(i)
- done;
- r, s
- end
-
-let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
- | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
- | Construct _) -> c
- | Cast (b,k,t) ->
- let b' = f l b in
- let t' = f l t in
- if b' == b && t' == t then c
- else mkCast (b',k,t')
- | Prod (na,t,b) ->
- let t' = f l t in
- let b' = f (g (na,None,t) l) b in
- if t' == t && b' == b then c
- else mkProd (na, t', b')
- | Lambda (na,t,b) ->
- let t' = f l t in
- let b' = f (g (na,None,t) l) b in
- if t' == t && b' == b then c
- else mkLambda (na, t', b')
- | LetIn (na,bo,t,b) ->
- let bo' = f l bo in
- let t' = f l t in
- let b' = f (g (na,Some bo,t) l) b in
- if bo' == bo && t' == t && b' == b then c
- else mkLetIn (na, bo', t', b')
- | App (c,[||]) -> assert false
- | App (t,al) ->
- (*Special treatment to be able to recognize partially applied subterms*)
- let a = al.(Array.length al - 1) in
- let app = (mkApp (t, Array.sub al 0 (Array.length al - 1))) in
- let app' = f l app in
- let a' = f l a in
- if app' == app && a' == a then c
- else mkApp (app', [| a' |])
- | Proj (p,b) ->
- let b' = f l b in
- if b' == b then c
- else mkProj (p, b')
- | Evar (e,al) ->
- let al' = Array.map_left (f l) al in
- if Array.for_all2 (==) al' al then c
- else mkEvar (e, al')
- | Case (ci,p,b,bl) ->
- (* In v8 concrete syntax, predicate is after the term to match! *)
- let b' = f l b in
- let p' = f l p in
- let bl' = Array.map_left (f l) bl in
- if b' == b && p' == p && bl' == bl then c
- else mkCase (ci, p', b', bl')
- | Fix (ln,(lna,tl,bl as fx)) ->
- let l' = fold_rec_types g fx l in
- let (tl', bl') = map_left2 (f l) tl (f l') bl in
- if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
- then c
- else mkFix (ln,(lna,tl',bl'))
- | CoFix(ln,(lna,tl,bl as fx)) ->
- let l' = fold_rec_types g fx l in
- let (tl', bl') = map_left2 (f l) tl (f l') bl in
- if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
- then c
- else mkCoFix (ln,(lna,tl',bl'))
-
-(* strong *)
-let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
- | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
- | Construct _) -> cstr
- | Cast (c,k, t) ->
- let c' = f l c in
- let t' = f l t in
- if c==c' && t==t' then cstr else mkCast (c', k, t')
- | Prod (na,t,c) ->
- let t' = f l t in
- let c' = f (g (na,None,t) l) c in
- if t==t' && c==c' then cstr else mkProd (na, t', c')
- | Lambda (na,t,c) ->
- let t' = f l t in
- let c' = f (g (na,None,t) l) c in
- if t==t' && c==c' then cstr else mkLambda (na, t', c')
- | LetIn (na,b,t,c) ->
- let b' = f l b in
- let t' = f l t in
- let c' = f (g (na,Some b,t) l) c in
- if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c')
- | App (c,al) ->
- let c' = f l c in
- let al' = Array.map (f l) al in
- if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al')
- | Proj (p,c) ->
- let c' = f l c in
- if c' == c then cstr else mkProj (p, c')
- | Evar (e,al) ->
- let al' = Array.map (f l) al in
- if Array.for_all2 (==) al al' then cstr else mkEvar (e, al')
- | Case (ci,p,c,bl) ->
- let p' = f l p in
- let c' = f l c in
- let bl' = Array.map (f l) bl in
- if p==p' && c==c' && Array.for_all2 (==) bl bl' then cstr else
- mkCase (ci, p', c', bl')
- | Fix (ln,(lna,tl,bl)) ->
- let tl' = Array.map (f l) tl in
- let l' =
- Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
- let bl' = Array.map (f l') bl in
- if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
- then cstr
- else mkFix (ln,(lna,tl',bl'))
- | CoFix(ln,(lna,tl,bl)) ->
- let tl' = Array.map (f l) tl in
- let l' =
- Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
- let bl' = Array.map (f l') bl in
- if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
- then cstr
- else mkCoFix (ln,(lna,tl',bl'))
-
-(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
- subterms of [c] starting from [acc] and proceeding from left to
- right according to the usual representation of the constructions as
- [fold_constr] but it carries an extra data [n] (typically a lift
- index) which is processed by [g] (which typically add 1 to [n]) at
- each binder traversal; it is not recursive *)
-
-let fold_constr_with_full_binders g f n acc c = match kind_of_term c with
- | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
- | Construct _) -> acc
- | Cast (c,_, t) -> f n (f n acc c) t
- | Prod (na,t,c) -> f (g (na,None,t) n) (f n acc t) c
- | Lambda (na,t,c) -> f (g (na,None,t) n) (f n acc t) c
- | LetIn (na,b,t,c) -> f (g (na,Some b,t) n) (f n (f n acc b) t) c
- | App (c,l) -> Array.fold_left (f n) (f n acc c) l
- | Proj (p,c) -> f n acc c
- | Evar (_,l) -> Array.fold_left (f n) acc l
- | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl
- | Fix (_,(lna,tl,bl)) ->
- let n' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in
- let fd = Array.map2 (fun t b -> (t,b)) tl bl in
- Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd
- | CoFix (_,(lna,tl,bl)) ->
- let n' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in
- let fd = Array.map2 (fun t b -> (t,b)) tl bl in
- Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd
-
-let fold_constr_with_binders g f n acc c =
- fold_constr_with_full_binders (fun _ x -> g x) f n acc c
-
-(* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate
- subterms of [c]; it carries an extra data [acc] which is processed by [g] at
- each binder traversal; it is not recursive and the order with which
- subterms are processed is not specified *)
-
-let iter_constr_with_full_binders g f l c = match kind_of_term c with
- | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
- | Construct _) -> ()
- | Cast (c,_, t) -> f l c; f l t
- | Prod (na,t,c) -> f l t; f (g (na,None,t) l) c
- | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c
- | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c
- | App (c,args) -> f l c; Array.iter (f l) args
- | Proj (p,c) -> f l c
- | Evar (_,args) -> Array.iter (f l) args
- | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl
- | Fix (_,(lna,tl,bl)) ->
- let l' = Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
- Array.iter (f l) tl;
- Array.iter (f l') bl
- | CoFix (_,(lna,tl,bl)) ->
- let l' = Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
- Array.iter (f l) tl;
- Array.iter (f l') bl
-
-(***************************)
-(* occurs check functions *)
-(***************************)
-
-exception Occur
-
-let occur_meta c =
- let rec occrec c = match kind_of_term c with
- | Meta _ -> raise Occur
- | _ -> iter_constr occrec c
- in try occrec c; false with Occur -> true
-
-let occur_existential c =
- let rec occrec c = match kind_of_term c with
- | Evar _ -> raise Occur
- | _ -> iter_constr occrec c
- in try occrec c; false with Occur -> true
-
-let occur_meta_or_existential c =
- let rec occrec c = match kind_of_term c with
- | Evar _ -> raise Occur
- | Meta _ -> raise Occur
- | _ -> iter_constr occrec c
- in try occrec c; false with Occur -> true
-
-let occur_evar n c =
- let rec occur_rec c = match kind_of_term c with
- | Evar (sp,_) when Evar.equal sp n -> raise Occur
- | _ -> iter_constr occur_rec c
- in
- try occur_rec c; false with Occur -> true
-
-let occur_in_global env id constr =
- let vars = vars_of_global env constr in
- if Id.Set.mem id vars then raise Occur
-
-let occur_var env id c =
- let rec occur_rec c =
- match kind_of_term c with
- | Var _ | Const _ | Ind _ | Construct _ -> occur_in_global env id c
- | _ -> iter_constr occur_rec c
- in
- try occur_rec c; false with Occur -> true
-
-let occur_var_in_decl env hyp (_,c,typ) =
- match c with
- | None -> occur_var env hyp typ
- | Some body ->
- occur_var env hyp typ ||
- occur_var env hyp body
-
-(* returns the list of free debruijn indices in a term *)
-
-let free_rels m =
- let rec frec depth acc c = match kind_of_term c with
- | Rel n -> if n >= depth then Int.Set.add (n-depth+1) acc else acc
- | _ -> fold_constr_with_binders succ frec depth acc c
- in
- frec 1 Int.Set.empty m
-
-(* collects all metavar occurrences, in left-to-right order, preserving
- * repetitions and all. *)
-
-let collect_metas c =
- let rec collrec acc c =
- match kind_of_term c with
- | Meta mv -> List.add_set Int.equal mv acc
- | _ -> fold_constr collrec acc c
- in
- List.rev (collrec [] c)
-
-(* collects all vars; warning: this is only visible vars, not dependencies in
- all section variables; for the latter, use global_vars_set *)
-let collect_vars c =
- let rec aux vars c = match kind_of_term c with
- | Var id -> Id.Set.add id vars
- | _ -> fold_constr aux vars c in
- aux Id.Set.empty c
-
-(* Tests whether [m] is a subterm of [t]:
- [m] is appropriately lifted through abstractions of [t] *)
-
-let dependent_main noevar univs m t =
- let eqc x y = if univs then fst (Universes.eq_constr_universes x y) else eq_constr_nounivs x y in
- let rec deprec m t =
- if eqc m t then
- raise Occur
- else
- match kind_of_term m, kind_of_term t with
- | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt ->
- deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm)));
- CArray.Fun1.iter deprec m
- (Array.sub lt
- (Array.length lm) ((Array.length lt) - (Array.length lm)))
- | _, Cast (c,_,_) when noevar && isMeta c -> ()
- | _, Evar _ when noevar -> ()
- | _ -> iter_constr_with_binders (fun c -> lift 1 c) deprec m t
- in
- try deprec m t; false with Occur -> true
-
-let dependent = dependent_main false false
-let dependent_no_evar = dependent_main true false
-
-let dependent_univs = dependent_main false true
-let dependent_univs_no_evar = dependent_main true true
-
-let dependent_in_decl a (_,c,t) =
- match c with
- | None -> dependent a t
- | Some body -> dependent a body || dependent a t
-
-let count_occurrences m t =
- let n = ref 0 in
- let rec countrec m t =
- if eq_constr m t then
- incr n
- else
- match kind_of_term m, kind_of_term t with
- | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt ->
- countrec m (mkApp (ft,Array.sub lt 0 (Array.length lm)));
- Array.iter (countrec m)
- (Array.sub lt
- (Array.length lm) ((Array.length lt) - (Array.length lm)))
- | _, Cast (c,_,_) when isMeta c -> ()
- | _, Evar _ -> ()
- | _ -> iter_constr_with_binders (lift 1) countrec m t
- in
- countrec m t;
- !n
-
-(* Synonymous *)
-let occur_term = dependent
-
-let pop t = lift (-1) t
-
-(***************************)
-(* bindings functions *)
-(***************************)
-
-type meta_type_map = (metavariable * types) list
-
-type meta_value_map = (metavariable * constr) list
-
-let rec subst_meta bl c =
- match kind_of_term c with
- | Meta i -> (try Int.List.assoc i bl with Not_found -> c)
- | _ -> map_constr (subst_meta bl) c
-
-(* First utilities for avoiding telescope computation for subst_term *)
-
-let prefix_application eq_fun (k,c) (t : constr) =
- let c' = collapse_appl c and t' = collapse_appl t in
- match kind_of_term c', kind_of_term t' with
- | App (f1,cl1), App (f2,cl2) ->
- let l1 = Array.length cl1
- and l2 = Array.length cl2 in
- if l1 <= l2
- && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then
- Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1)))
- else
- None
- | _ -> None
-
-let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) =
- let c' = collapse_appl c and t' = collapse_appl t in
- match kind_of_term c', kind_of_term t' with
- | App (f1,cl1), App (f2,cl2) ->
- let l1 = Array.length cl1
- and l2 = Array.length cl2 in
- if l1 <= l2
- && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then
- Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1)))
- else
- None
- | _ -> None
-
-(* Recognizing occurrences of a given subterm in a term: [subst_term c t]
- substitutes [(Rel 1)] for all occurrences of term [c] in a term [t];
- works if [c] has rels *)
-
-let subst_term_gen eq_fun c t =
- let rec substrec (k,c as kc) t =
- match prefix_application eq_fun kc t with
- | Some x -> x
- | None ->
- if eq_fun c t then mkRel k
- else
- map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t
- in
- substrec (1,c) t
-
-let subst_term = subst_term_gen eq_constr
-
-(* Recognizing occurrences of a given subterm in a term :
- [replace_term c1 c2 t] substitutes [c2] for all occurrences of
- term [c1] in a term [t]; works if [c1] and [c2] have rels *)
-
-let replace_term_gen eq_fun c by_c in_t =
- let rec substrec (k,c as kc) t =
- match my_prefix_application eq_fun kc by_c t with
- | Some x -> x
- | None ->
- (if eq_fun c t then (lift k by_c) else
- map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c))
- substrec kc t)
- in
- substrec (0,c) in_t
-
-let replace_term = replace_term_gen eq_constr
-
-let vars_of_env env =
- let s =
- Context.fold_named_context (fun (id,_,_) s -> Id.Set.add id s)
- (named_context env) ~init:Id.Set.empty in
- Context.fold_rel_context
- (fun (na,_,_) s -> match na with Name id -> Id.Set.add id s | _ -> s)
- (rel_context env) ~init:s
-
-let add_vname vars = function
- Name id -> Id.Set.add id vars
- | _ -> vars
-
-(*************************)
-(* Names environments *)
-(*************************)
-type names_context = Name.t list
-let add_name n nl = n::nl
-let lookup_name_of_rel p names =
- try List.nth names (p-1)
- with Invalid_argument _ | Failure _ -> raise Not_found
-let lookup_rel_of_name id names =
- let rec lookrec n = function
- | Anonymous :: l -> lookrec (n+1) l
- | (Name id') :: l -> if Id.equal id' id then n else lookrec (n+1) l
- | [] -> raise Not_found
- in
- lookrec 1 names
-let empty_names_context = []
-
-let ids_of_rel_context sign =
- Context.fold_rel_context
- (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l)
- sign ~init:[]
-
-let ids_of_named_context sign =
- Context.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[]
-
-let ids_of_context env =
- (ids_of_rel_context (rel_context env))
- @ (ids_of_named_context (named_context env))
-
-
-let names_of_rel_context env =
- List.map (fun (na,_,_) -> na) (rel_context env)
-
-let is_section_variable id =
- try let _ = Global.lookup_named id in true
- with Not_found -> false
-
-let isGlobalRef c =
- match kind_of_term c with
- | Const _ | Ind _ | Construct _ | Var _ -> true
- | _ -> false
-
-let is_template_polymorphic env f =
- match kind_of_term f with
- | Ind ind -> Environ.template_polymorphic_pind ind env
- | Const c -> Environ.template_polymorphic_pconstant c env
- | _ -> false
-
-let base_sort_cmp pb s0 s1 =
- match (s0,s1) with
- | (Prop c1, Prop c2) -> c1 == Null || c2 == Pos (* Prop <= Set *)
- | (Prop c1, Type u) -> pb == Reduction.CUMUL
- | (Type u1, Type u2) -> true
- | _ -> false
-
-(* eq_constr extended with universe erasure *)
-let compare_constr_univ f cv_pb t1 t2 =
- match kind_of_term t1, kind_of_term t2 with
- Sort s1, Sort s2 -> base_sort_cmp cv_pb s1 s2
- | Prod (_,t1,c1), Prod (_,t2,c2) ->
- f Reduction.CONV t1 t2 && f cv_pb c1 c2
- | _ -> compare_constr (fun t1 t2 -> f Reduction.CONV t1 t2) t1 t2
-
-let rec constr_cmp cv_pb t1 t2 = compare_constr_univ constr_cmp cv_pb t1 t2
-
-let eq_constr t1 t2 = constr_cmp Reduction.CONV t1 t2
-
-(* App(c,[t1,...tn]) -> ([c,t1,...,tn-1],tn)
- App(c,[||]) -> ([],c) *)
-let split_app c = match kind_of_term c with
- App(c,l) ->
- let len = Array.length l in
- if Int.equal len 0 then ([],c) else
- let last = Array.get l (len-1) in
- let prev = Array.sub l 0 (len-1) in
- c::(Array.to_list prev), last
- | _ -> assert false
-
-type subst = (rel_context*constr) Evar.Map.t
-
-exception CannotFilter
-
-let filtering env cv_pb c1 c2 =
- let evm = ref Evar.Map.empty in
- let define cv_pb e1 ev c1 =
- try let (e2,c2) = Evar.Map.find ev !evm in
- let shift = List.length e1 - List.length e2 in
- if constr_cmp cv_pb c1 (lift shift c2) then () else raise CannotFilter
- with Not_found ->
- evm := Evar.Map.add ev (e1,c1) !evm
- in
- let rec aux env cv_pb c1 c2 =
- match kind_of_term c1, kind_of_term c2 with
- | App _, App _ ->
- let ((p1,l1),(p2,l2)) = (split_app c1),(split_app c2) in
- let () = aux env cv_pb l1 l2 in
- begin match p1, p2 with
- | [], [] -> ()
- | (h1 :: p1), (h2 :: p2) ->
- aux env cv_pb (applistc h1 p1) (applistc h2 p2)
- | _ -> assert false
- end
- | Prod (n,t1,c1), Prod (_,t2,c2) ->
- aux env cv_pb t1 t2;
- aux ((n,None,t1)::env) cv_pb c1 c2
- | _, Evar (ev,_) -> define cv_pb env ev c1
- | Evar (ev,_), _ -> define cv_pb env ev c2
- | _ ->
- if compare_constr_univ
- (fun pb c1 c2 -> aux env pb c1 c2; true) cv_pb c1 c2 then ()
- else raise CannotFilter
- (* TODO: le reste des binders *)
- in
- aux env cv_pb c1 c2; !evm
-
-let decompose_prod_letin : constr -> int * rel_context * constr =
- let rec prodec_rec i l c = match kind_of_term c with
- | Prod (n,t,c) -> prodec_rec (succ i) ((n,None,t)::l) c
- | LetIn (n,d,t,c) -> prodec_rec (succ i) ((n,Some d,t)::l) c
- | Cast (c,_,_) -> prodec_rec i l c
- | _ -> i,l,c in
- prodec_rec 0 []
-
-let align_prod_letin c a : rel_context * constr =
- let (lc,_,_) = decompose_prod_letin c in
- let (la,l,a) = decompose_prod_letin a in
- if not (la >= lc) then invalid_arg "align_prod_letin";
- let (l1,l2) = Util.List.chop lc l in
- l2,it_mkProd_or_LetIn a l1
-
-(* We reduce a series of head eta-redex or nothing at all *)
-(* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *)
-(* Remplace 2 earlier buggish versions *)
-
-let rec eta_reduce_head c =
- match kind_of_term c with
- | Lambda (_,c1,c') ->
- (match kind_of_term (eta_reduce_head c') with
- | App (f,cl) ->
- let lastn = (Array.length cl) - 1 in
- if lastn < 0 then anomaly (Pp.str "application without arguments")
- else
- (match kind_of_term cl.(lastn) with
- | Rel 1 ->
- let c' =
- if Int.equal lastn 0 then f
- else mkApp (f, Array.sub cl 0 lastn)
- in
- if noccurn 1 c'
- then lift (-1) c'
- else c
- | _ -> c)
- | _ -> c)
- | _ -> c
-
-
-(* iterator on rel context *)
-let process_rel_context f env =
- let sign = named_context_val env in
- let rels = rel_context env in
- let env0 = reset_with_named_context sign env in
- Context.fold_rel_context f rels ~init:env0
-
-let assums_of_rel_context sign =
- Context.fold_rel_context
- (fun (na,c,t) l ->
- match c with
- Some _ -> l
- | None -> (na, t)::l)
- sign ~init:[]
-
-let map_rel_context_in_env f env sign =
- let rec aux env acc = function
- | d::sign ->
- aux (push_rel d env) (map_rel_declaration (f env) d :: acc) sign
- | [] ->
- acc
- in
- aux env [] (List.rev sign)
-
-let map_rel_context_with_binders f sign =
- let rec aux k = function
- | d::sign -> map_rel_declaration (f k) d :: aux (k-1) sign
- | [] -> []
- in
- aux (rel_context_length sign) sign
-
-let substl_rel_context l =
- map_rel_context_with_binders (fun k -> substnl l (k-1))
-
-let lift_rel_context n =
- map_rel_context_with_binders (liftn n)
-
-let smash_rel_context sign =
- let rec aux acc = function
- | [] -> acc
- | (_,None,_ as d) :: l -> aux (d::acc) l
- | (_,Some b,_) :: l ->
- (* Quadratic in the number of let but there are probably a few of them *)
- aux (List.rev (substl_rel_context [b] (List.rev acc))) l
- in List.rev (aux [] sign)
-
-let adjust_subst_to_rel_context sign l =
- let rec aux subst sign l =
- match sign, l with
- | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args'
- | (_,Some c,_)::sign', args' ->
- aux (substl subst c :: subst) sign' args'
- | [], [] -> List.rev subst
- | _ -> anomaly (Pp.str "Instance and signature do not match")
- in aux [] (List.rev sign) l
-
-let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init
-
-let rec mem_named_context id = function
- | (id',_,_) :: _ when Id.equal id id' -> true
- | _ :: sign -> mem_named_context id sign
- | [] -> false
-
-let compact_named_context_reverse sign =
- let compact l (i1,c1,t1) =
- match l with
- | [] -> [[i1],c1,t1]
- | (l2,c2,t2)::q ->
- if Option.equal Constr.equal c1 c2 && Constr.equal t1 t2
- then (i1::l2,c2,t2)::q
- else ([i1],c1,t1)::l
- in Context.fold_named_context_reverse compact ~init:[] sign
-
-let compact_named_context sign = List.rev (compact_named_context_reverse sign)
-
-let clear_named_body id env =
- let aux _ = function
- | (id',Some c,t) when Id.equal id id' -> push_named (id,None,t)
- | d -> push_named d in
- fold_named_context aux env ~init:(reset_context env)
-
-let global_vars env ids = Id.Set.elements (global_vars_set env ids)
-
-let global_vars_set_of_decl env = function
- | (_,None,t) -> global_vars_set env t
- | (_,Some c,t) ->
- Id.Set.union (global_vars_set env t)
- (global_vars_set env c)
-
-let dependency_closure env sign hyps =
- if Id.Set.is_empty hyps then [] else
- let (_,lh) =
- Context.fold_named_context_reverse
- (fun (hs,hl) (x,_,_ as d) ->
- if Id.Set.mem x hs then
- (Id.Set.union (global_vars_set_of_decl env d) (Id.Set.remove x hs),
- x::hl)
- else (hs,hl))
- ~init:(hyps,[])
- sign in
- List.rev lh
-
-(* Combinators on judgments *)
-
-let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type }
-let on_judgment_value f j = { j with uj_val = f j.uj_val }
-let on_judgment_type f j = { j with uj_type = f j.uj_type }
-
-(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k
- variables; skips let-in's *)
-let context_chop k ctx =
- let rec chop_aux acc = function
- | (0, l2) -> (List.rev acc, l2)
- | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t)
- | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
- | (_, []) -> anomaly (Pp.str "context_chop")
- in chop_aux [] (k,ctx)
-
-(* Do not skip let-in's *)
-let env_rel_context_chop k env =
- let rels = rel_context env in
- let ctx1,ctx2 = List.chop k rels in
- push_rel_context ctx2 (reset_with_named_context (named_context_val env) env),
- ctx1
-
-(*******************************************)
-(* Functions to deal with impossible cases *)
-(*******************************************)
-let impossible_default_case = ref None
-
-let set_impossible_default_clause c = impossible_default_case := Some c
-
-let coq_unit_judge =
- let na1 = Name (Id.of_string "A") in
- let na2 = Name (Id.of_string "H") in
- fun () ->
- match !impossible_default_case with
- | Some fn ->
- let (id,type_of_id), ctx = fn () in
- make_judge id type_of_id, ctx
- | None ->
- (* In case the constants id/ID are not defined *)
- make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1)))
- (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))),
- Univ.ContextSet.empty
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
deleted file mode 100644
index ca98f8d7..00000000
--- a/pretyping/termops.mli
+++ /dev/null
@@ -1,248 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Names
-open Term
-open Context
-open Environ
-
-(** printers *)
-val print_sort : sorts -> std_ppcmds
-val pr_sort_family : sorts_family -> std_ppcmds
-val pr_fix : (constr -> std_ppcmds) -> fixpoint -> std_ppcmds
-
-(** debug printer: do not use to display terms to the casual user... *)
-val set_print_constr : (env -> constr -> std_ppcmds) -> unit
-val print_constr : constr -> std_ppcmds
-val print_constr_env : env -> constr -> std_ppcmds
-val print_named_context : env -> std_ppcmds
-val pr_rel_decl : env -> rel_declaration -> std_ppcmds
-val print_rel_context : env -> std_ppcmds
-val print_env : env -> std_ppcmds
-
-(** about contexts *)
-val push_rel_assum : Name.t * types -> env -> env
-val push_rels_assum : (Name.t * types) list -> env -> env
-val push_named_rec_types : Name.t array * types array * 'a -> env -> env
-
-val lookup_rel_id : Id.t -> rel_context -> int * constr option * types
-(** Associates the contents of an identifier in a [rel_context]. Raise
- [Not_found] if there is no such identifier. *)
-
-(** Functions that build argument lists matching a block of binders or a context.
- [rel_vect n m] builds [|Rel (n+m);...;Rel(n+1)|]
- [extended_rel_vect n ctx] extends the [ctx] context of length [m]
- with [n] elements.
-*)
-val rel_vect : int -> int -> constr array
-val rel_list : int -> int -> constr list
-val extended_rel_list : int -> rel_context -> constr list
-val extended_rel_vect : int -> rel_context -> constr array
-
-(** iterators/destructors on terms *)
-val mkProd_or_LetIn : rel_declaration -> types -> types
-val mkProd_wo_LetIn : rel_declaration -> types -> types
-val it_mkProd : types -> (Name.t * types) list -> types
-val it_mkLambda : constr -> (Name.t * types) list -> constr
-val it_mkProd_or_LetIn : types -> rel_context -> types
-val it_mkProd_wo_LetIn : types -> rel_context -> types
-val it_mkLambda_or_LetIn : constr -> rel_context -> constr
-val it_mkNamedProd_or_LetIn : types -> named_context -> types
-val it_mkNamedProd_wo_LetIn : types -> named_context -> types
-val it_mkNamedLambda_or_LetIn : constr -> named_context -> constr
-
-(* Ad hoc version reinserting letin, assuming the body is defined in
- the context where the letins are expanded *)
-val it_mkLambda_or_LetIn_from_no_LetIn : constr -> rel_context -> constr
-
-(** {6 Generic iterators on constr} *)
-
-val map_constr_with_named_binders :
- (Name.t -> 'a -> 'a) ->
- ('a -> constr -> constr) -> 'a -> constr -> constr
-val map_constr_with_binders_left_to_right :
- (rel_declaration -> 'a -> 'a) ->
- ('a -> constr -> constr) ->
- 'a -> constr -> constr
-val map_constr_with_full_binders :
- (rel_declaration -> 'a -> 'a) ->
- ('a -> constr -> constr) -> 'a -> constr -> constr
-
-(** [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
- subterms of [c] starting from [acc] and proceeding from left to
- right according to the usual representation of the constructions as
- [fold_constr] but it carries an extra data [n] (typically a lift
- index) which is processed by [g] (which typically add 1 to [n]) at
- each binder traversal; it is not recursive *)
-
-val fold_constr_with_binders :
- ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b
-
-val fold_constr_with_full_binders :
- (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) ->
- 'a -> 'b -> constr -> 'b
-
-val iter_constr_with_full_binders :
- (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a ->
- constr -> unit
-
-(**********************************************************************)
-
-val strip_head_cast : constr -> constr
-val drop_extra_implicit_args : constr -> constr
-
-(** occur checks *)
-exception Occur
-val occur_meta : types -> bool
-val occur_existential : types -> bool
-val occur_meta_or_existential : types -> bool
-val occur_evar : existential_key -> types -> bool
-val occur_var : env -> Id.t -> types -> bool
-val occur_var_in_decl :
- env ->
- Id.t -> 'a * types option * types -> bool
-val free_rels : constr -> Int.Set.t
-
-(** [dependent m t] tests whether [m] is a subterm of [t] *)
-val dependent : constr -> constr -> bool
-val dependent_no_evar : constr -> constr -> bool
-val dependent_univs : constr -> constr -> bool
-val dependent_univs_no_evar : constr -> constr -> bool
-val dependent_in_decl : constr -> named_declaration -> bool
-val count_occurrences : constr -> constr -> int
-val collect_metas : constr -> int list
-val collect_vars : constr -> Id.Set.t (** for visible vars only *)
-val occur_term : constr -> constr -> bool (** Synonymous
- of dependent
- Substitution of metavariables *)
-type meta_value_map = (metavariable * constr) list
-val subst_meta : meta_value_map -> constr -> constr
-
-(** Type assignment for metavariables *)
-type meta_type_map = (metavariable * types) list
-
-(** [pop c] lifts by -1 the positive indexes in [c] *)
-val pop : constr -> constr
-
-(** {6 ... } *)
-(** Substitution of an arbitrary large term. Uses equality modulo
- reduction of let *)
-
-(** [subst_term_gen eq d c] replaces [Rel 1] by [d] in [c] using [eq]
- as equality *)
-val subst_term_gen :
- (constr -> constr -> bool) -> constr -> constr -> constr
-
-(** [replace_term_gen eq d e c] replaces [d] by [e] in [c] using [eq]
- as equality *)
-val replace_term_gen :
- (constr -> constr -> bool) ->
- constr -> constr -> constr -> constr
-
-(** [subst_term d c] replaces [Rel 1] by [d] in [c] *)
-val subst_term : constr -> constr -> constr
-
-(** [replace_term d e c] replaces [d] by [e] in [c] *)
-val replace_term : constr -> constr -> constr -> constr
-
-(** Alternative term equalities *)
-val base_sort_cmp : Reduction.conv_pb -> sorts -> sorts -> bool
-val compare_constr_univ : (Reduction.conv_pb -> constr -> constr -> bool) ->
- Reduction.conv_pb -> constr -> constr -> bool
-val constr_cmp : Reduction.conv_pb -> constr -> constr -> bool
-val eq_constr : constr -> constr -> bool (* FIXME rename: erases universes*)
-
-val eta_reduce_head : constr -> constr
-
-exception CannotFilter
-
-(** Lightweight first-order filtering procedure. Unification
- variables ar represented by (untyped) Evars.
- [filtering c1 c2] returns the substitution n'th evar ->
- (context,term), or raises [CannotFilter].
- Warning: Outer-kernel sort subtyping are taken into account: c1 has
- to be smaller than c2 wrt. sorts. *)
-type subst = (rel_context*constr) Evar.Map.t
-val filtering : rel_context -> Reduction.conv_pb -> constr -> constr -> subst
-
-val decompose_prod_letin : constr -> int * rel_context * constr
-val align_prod_letin : constr -> constr -> rel_context * constr
-
-(** Get the last arg of a constr intended to be an application *)
-val last_arg : constr -> constr
-
-(** Force the decomposition of a term as an applicative one *)
-val decompose_app_vect : constr -> constr * constr array
-
-val adjust_app_list_size : constr -> constr list -> constr -> constr list ->
- (constr * constr list * constr * constr list)
-val adjust_app_array_size : constr -> constr array -> constr -> constr array ->
- (constr * constr array * constr * constr array)
-
-(** name contexts *)
-type names_context = Name.t list
-val add_name : Name.t -> names_context -> names_context
-val lookup_name_of_rel : int -> names_context -> Name.t
-val lookup_rel_of_name : Id.t -> names_context -> int
-val empty_names_context : names_context
-val ids_of_rel_context : rel_context -> Id.t list
-val ids_of_named_context : named_context -> Id.t list
-val ids_of_context : env -> Id.t list
-val names_of_rel_context : env -> names_context
-
-val context_chop : int -> rel_context -> rel_context * rel_context
-val env_rel_context_chop : int -> env -> env * rel_context
-
-(** Set of local names *)
-val vars_of_env: env -> Id.Set.t
-val add_vname : Id.Set.t -> Name.t -> Id.Set.t
-
-(** other signature iterators *)
-val process_rel_context : (rel_declaration -> env -> env) -> env -> env
-val assums_of_rel_context : rel_context -> (Name.t * constr) list
-val lift_rel_context : int -> rel_context -> rel_context
-val substl_rel_context : constr list -> rel_context -> rel_context
-val smash_rel_context : rel_context -> rel_context (** expand lets in context *)
-val adjust_subst_to_rel_context : rel_context -> constr list -> constr list
-val map_rel_context_in_env :
- (env -> constr -> constr) -> env -> rel_context -> rel_context
-val map_rel_context_with_binders :
- (int -> constr -> constr) -> rel_context -> rel_context
-val fold_named_context_both_sides :
- ('a -> named_declaration -> named_declaration list -> 'a) ->
- named_context -> init:'a -> 'a
-val mem_named_context : Id.t -> named_context -> bool
-val compact_named_context : named_context -> named_list_context
-val compact_named_context_reverse : named_context -> named_list_context
-
-val clear_named_body : Id.t -> env -> env
-
-val global_vars : env -> constr -> Id.t list
-val global_vars_set_of_decl : env -> named_declaration -> Id.Set.t
-
-(** Gives an ordered list of hypotheses, closed by dependencies,
- containing a given set *)
-val dependency_closure : env -> named_context -> Id.Set.t -> Id.t list
-
-(** Test if an identifier is the basename of a global reference *)
-val is_section_variable : Id.t -> bool
-
-val isGlobalRef : constr -> bool
-
-val is_template_polymorphic : env -> constr -> bool
-
-(** Combinators on judgments *)
-
-val on_judgment : (types -> types) -> unsafe_judgment -> unsafe_judgment
-val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment
-val on_judgment_type : (types -> types) -> unsafe_judgment -> unsafe_judgment
-
-(** {6 Functions to deal with impossible cases } *)
-val set_impossible_default_clause : (unit -> (constr * types) Univ.in_universe_context_set) -> unit
-val coq_unit_judge : unit -> unsafe_judgment Univ.in_universe_context_set
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 3be98a1a..b8da6b68 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -12,11 +12,11 @@ open Globnames
open Decl_kinds
open Term
open Vars
-open Context
open Evd
open Util
open Typeclasses_errors
open Libobject
+open Context.Rel.Declaration
(*i*)
let typeclasses_unique_solutions = ref false
@@ -25,7 +25,7 @@ let get_typeclasses_unique_solutions () = !typeclasses_unique_solutions
open Goptions
-let set_typeclasses_unique_solutions =
+let _ =
declare_bool_option
{ optsync = true;
optdepr = false;
@@ -46,10 +46,10 @@ let set_typeclass_transparency gr local c = Hook.get set_typeclass_transparency
let (classes_transparent_state, classes_transparent_state_hook) = Hook.make ()
let classes_transparent_state () = Hook.get classes_transparent_state ()
-let solve_instantiation_problem = ref (fun _ _ _ _ -> assert false)
+let get_solve_one_instance, solve_one_instance_hook = Hook.make ()
let resolve_one_typeclass ?(unique=get_typeclasses_unique_solutions ()) env evm t =
- !solve_instantiation_problem env evm t unique
+ Hook.get get_solve_one_instance env evm t unique
type direction = Forward | Backward
@@ -59,13 +59,14 @@ type typeclass = {
cl_impl : global_reference;
(* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *)
- cl_context : (global_reference * bool) option list * rel_context;
+ cl_context : (global_reference * bool) option list * Context.Rel.t;
(* Context of definitions and properties on defs, will not be shared *)
- cl_props : rel_context;
+ cl_props : Context.Rel.t;
(* The method implementaions as projections. *)
- cl_projs : (Name.t * (direction * int option) option * constant option) list;
+ cl_projs : (Name.t * (direction * Vernacexpr.hint_info_expr) option
+ * constant option) list;
cl_strict : bool;
@@ -76,10 +77,9 @@ type typeclasses = typeclass Refmap.t
type instance = {
is_class: global_reference;
- is_pri: int option;
+ is_info: Vernacexpr.hint_info_expr;
(* Sections where the instance should be redeclared,
- -1 for discard, 0 for none, mutable to avoid redeclarations
- when multiple rebuild_object happen. *)
+ -1 for discard, 0 for none. *)
is_global: int;
is_poly: bool;
is_impl: global_reference;
@@ -89,15 +89,15 @@ type instances = (instance Refmap.t) Refmap.t
let instance_impl is = is.is_impl
-let instance_priority is = is.is_pri
+let hint_priority is = is.is_info.Vernacexpr.hint_priority
-let new_instance cl pri glob poly impl =
+let new_instance cl info glob poly impl =
let global =
if glob then Lib.sections_depth ()
else -1
in
{ is_class = cl.cl_impl;
- is_pri = pri ;
+ is_info = info ;
is_global = global ;
is_poly = poly;
is_impl = impl }
@@ -127,7 +127,7 @@ let typeclass_univ_instance (cl,u') =
in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst)
Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u')
in
- let subst_ctx = Context.map_rel_context (subst_univs_level_constr subst) in
+ let subst_ctx = Context.Rel.map (subst_univs_level_constr subst) in
{ cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context);
cl_props = subst_ctx cl.cl_props}, u'
@@ -150,7 +150,7 @@ let dest_class_arity env c =
let class_of_constr c =
try Some (dest_class_arity (Global.env ()) c)
- with e when Errors.noncritical e -> None
+ with e when CErrors.noncritical e -> None
let is_class_constr c =
try let gr, u = Universes.global_of_constr c in
@@ -181,9 +181,7 @@ let subst_class (subst,cl) =
let do_subst_con c = Mod_subst.subst_constant subst c
and do_subst c = Mod_subst.subst_mps subst c
and do_subst_gr gr = fst (subst_global subst gr) in
- let do_subst_ctx ctx = List.smartmap
- (fun (na, b, t) -> (na, Option.smartmap do_subst b, do_subst t))
- ctx in
+ let do_subst_ctx = List.smartmap (map_constr do_subst) in
let do_subst_context (grs,ctx) =
List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs,
do_subst_ctx ctx in
@@ -200,15 +198,19 @@ let discharge_class (_,cl) =
let repl = Lib.replacement_context () in
let rel_of_variable_context ctx = List.fold_right
( fun (n,_,b,t) (ctx', subst) ->
- let decl = (Name n, Option.map (substn_vars 1 subst) b, substn_vars 1 subst t) in
+ let decl = match b with
+ | None -> LocalAssum (Name n, substn_vars 1 subst t)
+ | Some b -> LocalDef (Name n, substn_vars 1 subst b, substn_vars 1 subst t)
+ in
(decl :: ctx', n :: subst)
) ctx ([], []) in
let discharge_rel_context subst n rel =
- let rel = map_rel_context (Cooking.expmod_constr repl) rel in
+ let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in
let ctx, _ =
List.fold_right
- (fun (id, b, t) (ctx, k) ->
- (id, Option.smartmap (substn_vars k subst) b, substn_vars k subst t) :: ctx, succ k)
+ (fun decl (ctx, k) ->
+ map_constr (substn_vars k subst) decl :: ctx, succ k
+ )
rel ([], n)
in ctx
in
@@ -218,15 +220,15 @@ let discharge_class (_,cl) =
| ConstRef cst -> Lib.section_segment_of_constant cst
| IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in
let discharge_context ctx' subst (grs, ctx) =
- let grs' =
- let newgrs = List.map (fun (_, _, t) ->
- match class_of_constr t with
- | None -> None
- | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true))
- ctx'
+ let grs' =
+ let newgrs = List.map (fun decl ->
+ match decl |> get_type |> class_of_constr with
+ | None -> None
+ | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true))
+ ctx'
in
- List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
- @ newgrs
+ List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
+ @ newgrs
in grs', discharge_rel_context subst 1 ctx @ ctx' in
let cl_impl' = Lib.discharge_global cl.cl_impl in
if cl_impl' == cl.cl_impl then cl else
@@ -247,7 +249,7 @@ let rebuild_class cl =
try
let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in
set_typeclass_transparency cst false false; cl
- with e when Errors.noncritical e -> cl
+ with e when CErrors.noncritical e -> cl
let class_input : typeclass -> obj =
declare_object
@@ -270,9 +272,11 @@ let check_instance env sigma c =
let (evd, c) = resolve_one_typeclass env sigma
(Retyping.get_type_of env sigma c) in
not (Evd.has_undefined evd)
- with e when Errors.noncritical e -> false
+ with e when CErrors.noncritical e -> false
+
+open Vernacexpr
-let build_subclasses ~check env sigma glob pri =
+let build_subclasses ~check env sigma glob { hint_priority = pri } =
let _id = Nametab.basename_of_global glob in
let _next_id =
let i = ref (-1) in
@@ -287,7 +291,7 @@ let build_subclasses ~check env sigma glob pri =
| None -> []
| Some (rels, ((tc,u), args)) ->
let instapp =
- Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels))
+ Reductionops.whd_beta sigma (appvectc c (Context.Rel.to_extended_vect 0 rels))
in
let projargs = Array.of_list (args @ [instapp]) in
let projs = List.map_filter
@@ -295,24 +299,24 @@ let build_subclasses ~check env sigma glob pri =
match b with
| None -> None
| Some (Backward, _) -> None
- | Some (Forward, pri') ->
+ | Some (Forward, info) ->
let proj = Option.get proj in
let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in
if check && check_instance env sigma body then None
else
- let pri =
- match pri, pri' with
+ let newpri =
+ match pri, info.hint_priority with
| Some p, Some p' -> Some (p + p')
| Some p, None -> Some (p + 1)
| _, _ -> None
in
- Some (ConstRef proj, pri, body)) tc.cl_projs
+ Some (ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs
in
- let declare_proj hints (cref, pri, body) =
+ let declare_proj hints (cref, info, body) =
let path' = cref :: path in
let ty = Retyping.get_type_of env sigma body in
let rest = aux pri body ty path' in
- hints @ (path', pri, body) :: rest
+ hints @ (path', info, body) :: rest
in List.fold_left declare_proj [] projs
in
let term = Universes.constr_of_global_univ (glob,Univ.UContext.instance ctx) in
@@ -366,11 +370,11 @@ let is_local i = Int.equal i.is_global (-1)
let add_instance check inst =
let poly = Global.is_polymorphic inst.is_impl in
add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst)
- inst.is_pri poly;
+ inst.is_info poly;
List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path
(is_local inst) pri poly)
(build_subclasses ~check:(check && not (isVarRef inst.is_impl))
- (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_pri)
+ (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info)
let rebuild_instance (action, inst) =
let () = match action with
@@ -402,26 +406,22 @@ let remove_instance i =
Lib.add_anonymous_leaf (instance_input (RemoveInstance, i));
remove_instance_hint i.is_impl
-let declare_instance pri local glob =
+let declare_instance info local glob =
let ty = Global.type_of_global_unsafe glob in
+ let info = Option.default {hint_priority = None; hint_pattern = None} info in
match class_of_constr ty with
| Some (rels, ((tc,_), args) as _cl) ->
- add_instance (new_instance tc pri (not local) (Flags.use_polymorphic_flag ()) glob)
-(* let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *)
-(* let entries = List.map (fun (path, pri, c) -> (pri, local, path, c)) hints in *)
-(* Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry entries); *)
-(* Auto.add_hints local [typeclasses_db] *)
-(* (Auto.HintsCutEntry (PathSeq (PathStar (PathAtom PathAny), path))) *)
+ add_instance (new_instance tc info (not local) (Flags.use_polymorphic_flag ()) glob)
| None -> ()
let add_class cl =
add_class cl;
List.iter (fun (n, inst, body) ->
match inst with
- | Some (Backward, pri) ->
+ | Some (Backward, info) ->
(match body with
- | None -> Errors.error "Non-definable projection can not be declared as a subinstance"
- | Some b -> declare_instance pri false (ConstRef b))
+ | None -> CErrors.error "Non-definable projection can not be declared as a subinstance"
+ | Some b -> declare_instance (Some info) false (ConstRef b))
| _ -> ())
cl.cl_projs
@@ -432,11 +432,7 @@ let add_class cl =
*)
let instance_constructor (cl,u) args =
- let filter (_, b, _) = match b with
- | None -> true
- | Some _ -> false
- in
- let lenpars = List.length (List.filter filter (snd cl.cl_context)) in
+ let lenpars = List.count is_local_assum (snd cl.cl_context) in
let pars = fst (List.chop lenpars args) in
match cl.cl_impl with
| IndRef ind ->
@@ -492,18 +488,21 @@ let is_instance = function
Nota: we will only check the resolvability status of undefined evars.
*)
-let resolvable = Store.field ()
+let resolvable = Proofview.Unsafe.typeclass_resolvable
let set_resolvable s b =
- Store.set s resolvable b
+ if b then Store.remove s resolvable
+ else Store.set s resolvable ()
let is_resolvable evi =
assert (match evi.evar_body with Evar_empty -> true | _ -> false);
- Option.default true (Store.get evi.evar_extra resolvable)
+ Option.is_empty (Store.get evi.evar_extra resolvable)
let mark_resolvability_undef b evi =
- let t = Store.set evi.evar_extra resolvable b in
- { evi with evar_extra = t }
+ if is_resolvable evi == (b : bool) then evi
+ else
+ let t = set_resolvable evi.evar_extra b in
+ { evi with evar_extra = t }
let mark_resolvability b evi =
assert (match evi.evar_body with Evar_empty -> true | _ -> false);
@@ -538,16 +537,16 @@ let has_typeclasses filter evd =
in
Evar.Map.exists check (Evd.undefined_map evd)
-let solve_instantiations_problem = ref (fun _ _ _ _ _ _ -> assert false)
+let get_solve_all_instances, solve_all_instances_hook = Hook.make ()
-let solve_problem env evd filter unique split fail =
- !solve_instantiations_problem env evd filter unique split fail
+let solve_all_instances env evd filter unique split fail =
+ Hook.get get_solve_all_instances env evd filter unique split fail
(** Profiling resolution of typeclasses *)
(* let solve_classeskey = Profile.declare_profile "solve_typeclasses" *)
(* let solve_problem = Profile.profile5 solve_classeskey solve_problem *)
-let resolve_typeclasses ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ())
+let resolve_typeclasses ?(fast_path = true) ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ())
?(split=true) ?(fail=true) env evd =
- if not (has_typeclasses filter evd) then evd
- else solve_problem env evd filter unique split fail
+ if fast_path && not (has_typeclasses filter evd) then evd
+ else solve_all_instances env evd filter unique split fail
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index 9e018f61..620bc367 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -9,7 +9,6 @@
open Names
open Globnames
open Term
-open Context
open Evd
open Environ
@@ -24,16 +23,16 @@ type typeclass = {
(** Context in which the definitions are typed. Includes both typeclass parameters and superclasses.
The boolean indicates if the typeclass argument is a direct superclass and the global reference
gives a direct link to the class itself. *)
- cl_context : (global_reference * bool) option list * rel_context;
+ cl_context : (global_reference * bool) option list * Context.Rel.t;
(** Context of definitions and properties on defs, will not be shared *)
- cl_props : rel_context;
+ cl_props : Context.Rel.t;
(** The methods implementations of the typeclass as projections.
Some may be undefinable due to sorting restrictions or simply undefined if
no name is provided. The [int option option] indicates subclasses whose hint has
the given priority. *)
- cl_projs : (Name.t * (direction * int option) option * constant option) list;
+ cl_projs : (Name.t * (direction * Vernacexpr.hint_info_expr) option * constant option) list;
(** Whether we use matching or full unification during resolution *)
cl_strict : bool;
@@ -51,7 +50,7 @@ val all_instances : unit -> instance list
val add_class : typeclass -> unit
-val new_instance : typeclass -> int option -> bool -> Decl_kinds.polymorphic ->
+val new_instance : typeclass -> Vernacexpr.hint_info_expr -> bool -> Decl_kinds.polymorphic ->
global_reference -> instance
val add_instance : instance -> unit
val remove_instance : instance -> unit
@@ -68,11 +67,11 @@ val dest_class_app : env -> constr -> typeclass puniverses * constr list
val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses
(** Just return None if not a class *)
-val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option
+val class_of_constr : constr -> (Context.Rel.t * (typeclass puniverses * constr list)) option
val instance_impl : instance -> global_reference
-val instance_priority : instance -> int option
+val hint_priority : instance -> int option
val is_class : global_reference -> bool
val is_instance : global_reference -> bool
@@ -102,7 +101,7 @@ val mark_resolvable : evar_info -> evar_info
val is_class_evar : evar_map -> evar_info -> bool
val is_class_type : evar_map -> types -> bool
-val resolve_typeclasses : ?filter:evar_filter -> ?unique:bool ->
+val resolve_typeclasses : ?fast_path:bool -> ?filter:evar_filter -> ?unique:bool ->
?split:bool -> ?fail:bool -> env -> evar_map -> evar_map
val resolve_one_typeclass : ?unique:bool -> env -> evar_map -> types -> open_constr
@@ -114,21 +113,22 @@ val classes_transparent_state : unit -> transparent_state
val add_instance_hint_hook :
(global_reference_or_constr -> global_reference list ->
- bool (* local? *) -> int option -> Decl_kinds.polymorphic -> unit) Hook.t
+ bool (* local? *) -> Vernacexpr.hint_info_expr -> Decl_kinds.polymorphic -> unit) Hook.t
val remove_instance_hint_hook : (global_reference -> unit) Hook.t
val add_instance_hint : global_reference_or_constr -> global_reference list ->
- bool -> int option -> Decl_kinds.polymorphic -> unit
+ bool -> Vernacexpr.hint_info_expr -> Decl_kinds.polymorphic -> unit
val remove_instance_hint : global_reference -> unit
-val solve_instantiations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) ref
-val solve_instantiation_problem : (env -> evar_map -> types -> bool -> open_constr) ref
+val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t
+val solve_one_instance_hook : (env -> evar_map -> types -> bool -> open_constr) Hook.t
-val declare_instance : int option -> bool -> global_reference -> unit
+val declare_instance : Vernacexpr.hint_info_expr option -> bool -> global_reference -> unit
(** Build the subinstances hints for a given typeclass object.
check tells if we should check for existence of the
subinstances and add only the missing ones. *)
-val build_subclasses : check:bool -> env -> evar_map -> global_reference -> int option (* priority *) ->
- (global_reference list * int option * constr) list
+val build_subclasses : check:bool -> env -> evar_map -> global_reference ->
+ Vernacexpr.hint_info_expr ->
+ (global_reference list * Vernacexpr.hint_info_expr * constr) list
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
index a0f63198..b1dfb19a 100644
--- a/pretyping/typeclasses_errors.ml
+++ b/pretyping/typeclasses_errors.ml
@@ -9,7 +9,6 @@
(*i*)
open Names
open Term
-open Context
open Environ
open Constrexpr
open Globnames
@@ -20,7 +19,7 @@ type contexts = Parameters | Properties
type typeclass_error =
| NotAClass of constr
| UnboundMethod of global_reference * Id.t Loc.located (* Class name, method *)
- | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *)
+ | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (* found, expected *)
exception TypeClassError of env * typeclass_error
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
index 7facb06f..ee76f638 100644
--- a/pretyping/typeclasses_errors.mli
+++ b/pretyping/typeclasses_errors.mli
@@ -9,7 +9,6 @@
open Loc
open Names
open Term
-open Context
open Environ
open Constrexpr
open Globnames
@@ -19,7 +18,7 @@ type contexts = Parameters | Properties
type typeclass_error =
| NotAClass of constr
| UnboundMethod of global_reference * Id.t located (** Class name, method *)
- | MismatchedContextInstance of contexts * constr_expr list * rel_context (** found, expected *)
+ | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (** found, expected *)
exception TypeClassError of env * typeclass_error
@@ -27,5 +26,5 @@ val not_a_class : env -> constr -> 'a
val unbound_method : env -> global_reference -> Id.t located -> 'a
-val mismatched_ctx_inst : env -> contexts -> constr_expr list -> rel_context -> 'a
+val mismatched_ctx_inst : env -> contexts -> constr_expr list -> Context.Rel.t -> 'a
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index eb16628b..9e9997f7 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Term
open Vars
@@ -18,6 +18,7 @@ open Inductive
open Inductiveops
open Typeops
open Arguments_renaming
+open Context.Rel.Declaration
let meta_type evd mv =
let ty =
@@ -35,10 +36,10 @@ let inductive_type_knowing_parameters env (ind,u) jl =
Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp
let e_type_judgment env evdref j =
- match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with
+ match kind_of_term (whd_all env !evdref j.uj_type) with
| Sort s -> {utj_val = j.uj_val; utj_type = s }
| Evar ev ->
- let (evd,s) = Evarutil.define_evar_as_sort env !evdref ev in
+ let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in
evdref := evd; { utj_val = j.uj_val; utj_type = s }
| _ -> error_not_type env j
@@ -53,14 +54,14 @@ let e_judge_of_apply env evdref funj argjv =
{ uj_val = mkApp (j_val funj, Array.map j_val argjv);
uj_type = typ }
| hj::restjl ->
- match kind_of_term (whd_betadeltaiota env !evdref typ) with
+ match kind_of_term (whd_all env !evdref typ) with
| Prod (_,c1,c2) ->
if Evarconv.e_cumul env evdref hj.uj_type c1 then
apply_rec (n+1) (subst1 hj.uj_val c2) restjl
else
error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv
| Evar ev ->
- let (evd',t) = Evarutil.define_evar_as_product !evdref ev in
+ let (evd',t) = Evardefine.define_evar_as_product !evdref ev in
evdref := evd';
let (_,_,c2) = destProd t in
apply_rec (n+1) (subst1 hj.uj_val c2) restjl
@@ -86,18 +87,18 @@ let e_is_correct_arity env evdref c pj ind specif params =
let allowed_sorts = elim_sorts specif in
let error () = error_elim_arity env ind allowed_sorts c pj None in
let rec srec env pt ar =
- let pt' = whd_betadeltaiota env !evdref pt in
+ let pt' = whd_all env !evdref pt in
match kind_of_term pt', ar with
- | Prod (na1,a1,t), (_,None,a1')::ar' ->
+ | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' ->
if not (Evarconv.e_cumul env evdref a1 a1') then error ();
- srec (push_rel (na1,None,a1) env) t ar'
+ srec (push_rel (LocalAssum (na1,a1)) env) t ar'
| Sort s, [] ->
if not (Sorts.List.mem (Sorts.family s) allowed_sorts)
then error ()
| Evar (ev,_), [] ->
let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in
evdref := Evd.define ev (mkSort s) evd
- | _, (_,Some _,_ as d)::ar' ->
+ | _, (LocalDef _ as d)::ar' ->
srec (push_rel d env) (lift 1 pt') ar'
| _ ->
error ()
@@ -109,23 +110,32 @@ let e_type_case_branches env evdref (ind,largs) pj c =
let nparams = inductive_params specif in
let (params,realargs) = List.chop nparams largs in
let p = pj.uj_val in
- let univ = e_is_correct_arity env evdref c pj ind specif params in
+ let () = e_is_correct_arity env evdref c pj ind specif params in
let lc = build_branches_type ind specif params p in
- let n = (snd specif).Declarations.mind_nrealargs in
- let ty =
- whd_betaiota !evdref (Reduction.betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) in
- (lc, ty, univ)
+ let n = (snd specif).Declarations.mind_nrealdecls in
+ let ty = whd_betaiota !evdref (lambda_applist_assum (n+1) p (realargs@[c])) in
+ (lc, ty)
let e_judge_of_case env evdref ci pj cj lfj =
let indspec =
try find_mrectype env !evdref cj.uj_type
with Not_found -> error_case_not_inductive env cj in
let _ = check_case_info env (fst indspec) ci in
- let (bty,rslty,univ) = e_type_case_branches env evdref indspec pj cj.uj_val in
+ let (bty,rslty) = e_type_case_branches env evdref indspec pj cj.uj_val in
e_check_branch_types env evdref (fst indspec) cj (lfj,bty);
{ uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj);
uj_type = rslty }
+let check_type_fixpoint loc env evdref lna lar vdefj =
+ let lt = Array.length vdefj in
+ if Int.equal (Array.length lar) lt then
+ for i = 0 to lt-1 do
+ if not (Evarconv.e_cumul env evdref (vdefj.(i)).uj_type
+ (lift lt lar.(i))) then
+ Pretype_errors.error_ill_typed_rec_body_loc loc env !evdref
+ i lna vdefj lar
+ done
+
(* FIXME: might depend on the level of actual parameters!*)
let check_allowed_sort env sigma ind c p =
let pj = Retyping.get_judgment_of env sigma p in
@@ -230,14 +240,14 @@ let rec execute env evdref cstr =
| Lambda (name,c1,c2) ->
let j = execute env evdref c1 in
let var = e_type_judgment env evdref j in
- let env1 = push_rel (name,None,var.utj_val) env in
+ let env1 = push_rel (LocalAssum (name, var.utj_val)) env in
let j' = execute env1 evdref c2 in
judge_of_abstraction env1 name var j'
| Prod (name,c1,c2) ->
let j = execute env evdref c1 in
let varj = e_type_judgment env evdref j in
- let env1 = push_rel (name,None,varj.utj_val) env in
+ let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in
let j' = execute env1 evdref c2 in
let varj' = e_type_judgment env1 evdref j' in
judge_of_product env name varj varj'
@@ -247,7 +257,7 @@ let rec execute env evdref cstr =
let j2 = execute env evdref c2 in
let j2 = e_type_judgment env evdref j2 in
let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in
- let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
+ let env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in
let j3 = execute env1 evdref c3 in
judge_of_letin env name j1 j2 j3
@@ -263,12 +273,12 @@ and execute_recdef env evdref (names,lar,vdef) =
let env1 = push_rec_types (names,lara,vdef) env in
let vdefj = execute_array env1 evdref vdef in
let vdefv = Array.map j_val vdefj in
- let _ = type_fixpoint env1 names lara vdefj in
+ let _ = check_type_fixpoint Loc.ghost env1 evdref names lara vdefj in
(names,lara,vdefv)
and execute_array env evdref = Array.map (execute env evdref)
-let check env evdref c t =
+let e_check env evdref c t =
let env = enrich_env env evdref in
let j = execute env evdref c in
if not (Evarconv.e_cumul env evdref j.uj_type t) then
@@ -284,7 +294,7 @@ let unsafe_type_of env evd c =
(* Sort of a type *)
-let sort_of env evdref c =
+let e_sort_of env evdref c =
let env = enrich_env env evdref in
let j = execute env evdref c in
let a = e_type_judgment env evdref j in
@@ -311,10 +321,10 @@ let e_type_of ?(refresh=false) env evdref c =
c
else j.uj_type
-let solve_evars env evdref c =
+let e_solve_evars env evdref c =
let env = enrich_env env evdref in
let c = (execute env evdref c).uj_val in
(* side-effect on evdref *)
nf_evar !evdref c
-let _ = Evarconv.set_solve_evars solve_evars
+let _ = Evarconv.set_solve_evars e_solve_evars
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index dafd7523..04e5e40b 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -24,18 +24,23 @@ val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types
val e_type_of : ?refresh:bool -> env -> evar_map ref -> constr -> types
(** Typecheck a type and return its sort *)
-val sort_of : env -> evar_map ref -> types -> sorts
+val e_sort_of : env -> evar_map ref -> types -> sorts
(** Typecheck a term has a given type (assuming the type is OK) *)
-val check : env -> evar_map ref -> constr -> types -> unit
+val e_check : env -> evar_map ref -> constr -> types -> unit
(** Returns the instantiated type of a metavariable *)
val meta_type : evar_map -> metavariable -> types
(** Solve existential variables using typing *)
-val solve_evars : env -> evar_map ref -> constr -> constr
+val e_solve_evars : env -> evar_map ref -> constr -> constr
(** Raise an error message if incorrect elimination for this inductive *)
(** (first constr is term to match, second is return predicate) *)
val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr ->
unit
+
+(** Raise an error message if bodies have types not unifiable with the
+ expected ones *)
+val check_type_fixpoint : Loc.t -> env -> evar_map ref ->
+ Names.Name.t array -> types array -> unsafe_judgment array -> unit
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index f97f6fbc..25931869 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Pp
open Util
open Names
@@ -19,6 +19,7 @@ open Evd
open Reduction
open Reductionops
open Evarutil
+open Evardefine
open Evarsolve
open Pretype_errors
open Retyping
@@ -27,6 +28,8 @@ open Recordops
open Locus
open Locusops
open Find_subterm
+open Sigma.Notations
+open Context.Named.Declaration
let keyed_unification = ref (false)
let _ = Goptions.declare_bool_option {
@@ -57,7 +60,7 @@ let occur_meta_or_undefined_evar evd c =
| Evar_defined c ->
occrec c; Array.iter occrec args
| Evar_empty -> raise Occur)
- | _ -> iter_constr occrec c
+ | _ -> Constr.iter occrec c
in try occrec c; false with Occur | Not_found -> true
let occur_meta_evd sigma mv c =
@@ -66,7 +69,7 @@ let occur_meta_evd sigma mv c =
let c = whd_evar sigma (whd_meta sigma c) in
match kind_of_term c with
| Meta mv' when Int.equal mv mv' -> raise Occur
- | _ -> iter_constr occrec c
+ | _ -> Constr.iter occrec c
in try occrec c; false with Occur -> true
(* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
@@ -74,7 +77,10 @@ let occur_meta_evd sigma mv c =
let abstract_scheme env evd c l lname_typ =
List.fold_left2
- (fun (t,evd) (locc,a) (na,_,ta) ->
+ (fun (t,evd) (locc,a) decl ->
+ let open Context.Rel.Declaration in
+ let na = get_name decl in
+ let ta = get_type decl in
let na = match kind_of_term a with Var id -> Name id | _ -> na in
(* [occur_meta ta] test removed for support of eelim/ecase but consequences
are unclear...
@@ -107,7 +113,9 @@ let set_occurrences_of_last_arg args =
Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args)
let abstract_list_all_with_dependencies env evd typ c l =
- let evd,ev = new_evar env evd typ in
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (ev, evd, _) = new_evar env evd typ in
+ let evd = Sigma.to_evar_map evd in
let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in
let n = List.length l in
let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in
@@ -143,7 +151,7 @@ let rec subst_meta_instances bl c =
| Meta i ->
let select (j,_,_) = Int.equal i j in
(try pi2 (List.find select bl) with Not_found -> c)
- | _ -> map_constr (subst_meta_instances bl) c
+ | _ -> Constr.map (subst_meta_instances bl) c
(** [env] should be the context in which the metas live *)
@@ -161,7 +169,7 @@ let pose_all_metas_as_evars env evd t =
evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref;
ev)
| _ ->
- map_constr aux t in
+ Constr.map aux t in
let c = aux t in
(* side-effect *)
(!evdref, c)
@@ -356,6 +364,22 @@ let set_no_delta_flags flags = {
resolve_evars = flags.resolve_evars
}
+(* For the first phase of keyed unification, restrict
+ to conversion (including beta-iota) only on closed terms *)
+let set_no_delta_open_core_flags flags = { flags with
+ modulo_delta = empty_transparent_state;
+ modulo_betaiota = false;
+}
+
+let set_no_delta_open_flags flags = {
+ core_unify_flags = set_no_delta_open_core_flags flags.core_unify_flags;
+ merge_unify_flags = set_no_delta_open_core_flags flags.merge_unify_flags;
+ subterm_unify_flags = set_no_delta_open_core_flags flags.subterm_unify_flags;
+ allow_K_in_toplevel_higher_order_unification =
+ flags.allow_K_in_toplevel_higher_order_unification;
+ resolve_evars = flags.resolve_evars
+}
+
(* Default flag for the "simple apply" version of unification of a *)
(* type against a type (e.g. apply) *)
(* We set only the flags available at the time the new "apply" extended *)
@@ -436,7 +460,7 @@ let use_metas_pattern_unification flags nb l =
Array.for_all (fun c -> isRel c && destRel c <= nb) l
type key =
- | IsKey of Closure.table_key
+ | IsKey of CClosure.table_key
| IsProj of projection * constr
let expand_table_key env = function
@@ -455,8 +479,8 @@ let unfold_projection env p stk =
let expand_key ts env sigma = function
| Some (IsKey k) -> expand_table_key env k
| Some (IsProj (p, c)) ->
- let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma
- Cst_stack.empty (c, unfold_projection env p [])))
+ let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma
+ Cst_stack.empty (c, unfold_projection env p [])))
in if Term.eq_constr (mkProj (p, c)) red then None else Some red
| None -> None
@@ -481,7 +505,8 @@ let key_of env b flags f =
Id.Pred.mem id (fst flags.modulo_delta) ->
Some (IsKey (VarKey id))
| Proj (p, c) when Projection.unfolded p
- || Cpred.mem (Projection.constant p) (snd flags.modulo_delta) ->
+ || (is_transparent env (ConstKey (Projection.constant p)) &&
+ (Cpred.mem (Projection.constant p) (snd flags.modulo_delta))) ->
Some (IsProj (p, c))
| _ -> None
@@ -547,7 +572,8 @@ let constr_cmp pb sigma flags t u =
else sigma, b
let do_reduce ts (env, nb) sigma c =
- Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma Cst_stack.empty (c, Stack.empty)))
+ Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state
+ ts env sigma Cst_stack.empty (c, Stack.empty)))
let use_full_betaiota flags =
flags.modulo_betaiota && Flags.version_strictly_greater Flags.V8_3
@@ -556,6 +582,19 @@ let isAllowedEvar flags c = match kind_of_term c with
| Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars)
| _ -> false
+
+let subst_defined_metas_evars (bl,el) c =
+ let rec substrec c = match kind_of_term c with
+ | Meta i ->
+ let select (j,_,_) = Int.equal i j in
+ substrec (pi2 (List.find select bl))
+ | Evar (evk,args) ->
+ let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in
+ (try substrec (pi3 (List.find select el))
+ with Not_found -> Constr.map substrec c)
+ | _ -> Constr.map substrec c
+ in try Some (substrec c) with Not_found -> None
+
let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN =
match subst_defined_metas_evars (metasubst,[]) tyM with
| None -> sigma
@@ -592,7 +631,7 @@ let is_eta_constructor_app env ts f l1 term =
| Construct (((_, i as ind), j), u) when i == 0 && j == 1 ->
let mib = lookup_mind (fst ind) env in
(match mib.Declarations.mind_record with
- | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite &&
+ | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite &&
Array.length projs == Array.length l1 - mib.Declarations.mind_nparams ->
(** Check that the other term is neutral *)
is_neutral env ts term
@@ -619,7 +658,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
and cN = Evarutil.whd_head_evar sigma curn in
let () =
if !debug_unification then
- msg_debug (Termops.print_constr_env curenv cM ++ str" ~= " ++ Termops.print_constr_env curenv cN)
+ Feedback.msg_debug (Termops.print_constr_env curenv cM ++ str" ~= " ++ Termops.print_constr_env curenv cN)
in
match (kind_of_term cM,kind_of_term cN) with
| Meta k1, Meta k2 ->
@@ -704,7 +743,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
then Evd.set_leq_sort curenv sigma s1 s2
else Evd.set_eq_sort curenv sigma s1 s2
in (sigma', metasubst, evarsubst)
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
error_cannot_unify curenv sigma (m,n))
| Lambda (na,t1,c1), Lambda (_,t2,c2) ->
@@ -1016,12 +1055,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
else error_cannot_unify (fst curenvnb) sigma (cM,cN)
in
- if !debug_unification then msg_debug (str "Starting unification");
+ if !debug_unification then Feedback.msg_debug (str "Starting unification");
let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in
try
let res =
- if occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n
- || subterm_restriction opt flags then None
+ if subterm_restriction opt flags ||
+ occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n
+ then
+ None
else
let sigma, b = match flags.modulo_conv_on_closed_terms with
| Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n
@@ -1037,11 +1078,12 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb
let a = match res with
| Some sigma -> sigma, ms, es
| None -> unirec_rec (env,0) cv_pb opt subst m n in
- if !debug_unification then msg_debug (str "Leaving unification with success");
+ if !debug_unification then Feedback.msg_debug (str "Leaving unification with success");
a
with e ->
- if !debug_unification then msg_debug (str "Leaving unification with failure");
- raise e
+ let e = CErrors.push e in
+ if !debug_unification then Feedback.msg_debug (str "Leaving unification with failure");
+ iraise e
let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env
@@ -1050,7 +1092,7 @@ let left = true
let right = false
let rec unify_with_eta keptside flags env sigma c1 c2 =
-(* Question: try whd_betadeltaiota on ci if not two lambdas? *)
+(* Question: try whd_all on ci if not two lambdas? *)
match kind_of_term c1, kind_of_term c2 with
| (Lambda (na,t1,c1'), Lambda (_,t2,c2')) ->
let env' = push_rel_assum (na,t1) env in
@@ -1098,11 +1140,11 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
else (right, st2, res)
| (IsSuperType,IsSubType) ->
(try (left, IsSubType, unify_0 env sigma CUMUL flags c2 c1)
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
(right, IsSubType, unify_0 env sigma CUMUL flags c1 c2))
| (IsSubType,IsSuperType) ->
(try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2)
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
(right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1))
(* Unification
@@ -1154,31 +1196,31 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
* close it off. But this might not always work,
* since other metavars might also need to be resolved. *)
-let applyHead env evd n c =
- let rec apprec n c cty evd =
+let applyHead env (type r) (evd : r Sigma.t) n c =
+ let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma =
+ fun n c cty p evd ->
if Int.equal n 0 then
- (evd, c)
+ Sigma (c, evd, p)
else
- match kind_of_term (whd_betadeltaiota env evd cty) with
+ match kind_of_term (whd_all env (Sigma.to_evar_map evd) cty) with
| Prod (_,c1,c2) ->
- let (evd',evar) =
- Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
- apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
+ let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
+ apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd'
| _ -> error "Apply_Head_Then"
in
- apprec n c (Typing.unsafe_type_of env evd c) evd
-
+ apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd
+
let is_mimick_head ts f =
match kind_of_term f with
- | Const (c,u) -> not (Closure.is_transparent_constant ts c)
- | Var id -> not (Closure.is_transparent_variable ts id)
+ | Const (c,u) -> not (CClosure.is_transparent_constant ts c)
+ | Var id -> not (CClosure.is_transparent_variable ts id)
| (Rel _|Construct _|Ind _) -> true
| _ -> false
let try_to_coerce env evd c cty tycon =
let j = make_judge c cty in
let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j tycon in
- let evd' = Evarconv.consider_remaining_unif_problems env evd' in
+ let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in
let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in
(evd',j'.uj_val)
@@ -1228,7 +1270,11 @@ let solve_simple_evar_eqn ts env evd ev rhs =
| UnifFailure (evd,reason) ->
error_cannot_unify env evd ~reason (mkEvar ev,rhs);
| Success evd ->
- Evarconv.consider_remaining_unif_problems env evd
+ if Flags.version_less_or_equal Flags.V8_5 then
+ (* We used to force solving unrelated problems at arbitrary times *)
+ Evarconv.solve_unif_constraints_with_heuristics env evd
+ else (* solve_simple_eqn calls reconsider_unif_constraints itself *)
+ evd
(* [w_merge env sigma b metas evars] merges common instances in metas
or in evars, possibly generating new unification problems; if [b]
@@ -1255,7 +1301,6 @@ let w_merge env with_types flags (evd,metas,evars) =
if is_mimick_head flags.modulo_delta f then
let evd' =
mimick_undefined_evar evd flags f (Array.length cl) evk in
- (* let evd' = Evarconv.consider_remaining_unif_problems env evd' in *)
w_merge_rec evd' metas evars eqns
else
let evd' =
@@ -1303,7 +1348,7 @@ let w_merge env with_types flags (evd,metas,evars) =
else
let evd' =
if occur_meta_evd evd mv c then
- if isMetaOf mv (whd_betadeltaiota env evd c) then evd
+ if isMetaOf mv (whd_all env evd c) then evd
else error_cannot_unify env evd (mkMeta mv,c)
else
meta_assign mv (c,(status,TypeProcessed)) evd in
@@ -1313,7 +1358,7 @@ let w_merge env with_types flags (evd,metas,evars) =
let rec process_eqns failures = function
| (mv,status,c)::eqns ->
(match (try Inl (unify_type env evd flags mv status c)
- with e when Errors.noncritical e -> Inr e)
+ with e when CErrors.noncritical e -> Inr e)
with
| Inr e -> process_eqns (((mv,status,c),e)::failures) eqns
| Inl (evd,metas,evars) ->
@@ -1327,7 +1372,9 @@ let w_merge env with_types flags (evd,metas,evars) =
and mimick_undefined_evar evd flags hdc nargs sp =
let ev = Evd.find_undefined evd sp in
let sp_env = Global.env_of_context ev.evar_hyps in
- let (evd', c) = applyHead sp_env evd nargs hdc in
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (c, evd', _) = applyHead sp_env evd nargs hdc in
+ let evd' = Sigma.to_evar_map evd' in
let (evd'',mc,ec) =
unify_0 sp_env evd' CUMUL flags
(get_type_of sp_env evd' c) ev.evar_concl in
@@ -1345,10 +1392,11 @@ let w_merge env with_types flags (evd,metas,evars) =
in w_merge_rec evd [] [] eqns
in
let res = (* merge constraints *)
- w_merge_rec evd (order_metas metas) (List.rev evars) []
+ w_merge_rec evd (order_metas metas)
+ (* Assign evars in the order of assignments during unification *)
+ (List.rev evars) []
in
- if with_types then check_types res
- else res
+ if with_types then check_types res else res
let w_unify_meta_types env ?(flags=default_unify_flags ()) evd =
let metas,evd = retract_coercible_metas evd in
@@ -1406,7 +1454,7 @@ let w_typed_unify_array env evd flags f1 l1 f2 l2 =
let subst = Array.fold_left2 fold_subst subst l1 l2 in
let evd = w_merge env true flags.merge_unify_flags subst in
try_resolve_typeclasses env evd flags.resolve_evars
- (mkApp(f1,l1)) (mkApp(f2,l2))
+ (mkApp(f1,l1)) (mkApp(f2,l2))
(* takes a substitution s, an open term op and a closed term cl
try to find a subterm of cl which matches op, if op is just a Meta
@@ -1430,15 +1478,16 @@ let indirectly_dependent c d decls =
it is needed otherwise, as e.g. when abstracting over "2" in
"forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious
way to see that the second hypothesis depends indirectly over 2 *)
- List.exists (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls
+ List.exists (fun d' -> dependent_in_decl (mkVar (get_id d')) d) decls
let indirect_dependency d decls =
- pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls))
+ decls |> List.filter (fun d' -> dependent_in_decl (mkVar (get_id d')) d) |> List.hd |> get_id
let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) =
+ let current_sigma = Sigma.to_evar_map current_sigma in
let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in
let sigma, subst = nf_univ_variables sigma in
- sigma, subst_univs_constr subst (nf_evar sigma c)
+ Sigma.Unsafe.of_pair (subst_univs_constr subst (nf_evar sigma c), sigma)
let default_matching_core_flags sigma =
let ts = Names.full_transparent_state in {
@@ -1450,9 +1499,7 @@ let default_matching_core_flags sigma =
check_applied_meta_types = true;
use_pattern_unification = false;
use_meta_bound_pattern_unification = false;
- frozen_evars =
- fold_undefined (fun evk _ evars -> Evar.Set.add evk evars)
- sigma Evar.Set.empty;
+ frozen_evars = Evar.Map.domain (Evd.undefined_map sigma);
restrict_conv_on_strict_subterms = false;
modulo_betaiota = false;
modulo_eta = false;
@@ -1514,11 +1561,12 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) =
| PretypeError (_,_,CannotUnify (c1,c2,Some e)) ->
raise (NotUnifiable (Some (c1,c2,e)))
(** MS: This is pretty bad, it catches Not_found for example *)
- | e when Errors.noncritical e -> raise (NotUnifiable None) in
+ | e when CErrors.noncritical e -> raise (NotUnifiable None) in
let merge_fun c1 c2 =
match c1, c2 with
- | Some (evd,c1,_) as x, Some (_,c2,_) ->
- if is_conv env sigma c1 c2 then x else raise (NotUnifiable None)
+ | Some (evd,c1,x), Some (_,c2,_) ->
+ let (evd,b) = infer_conv ~pb:CONV env evd c1 c2 in
+ if b then Some (evd, c1, x) else raise (NotUnifiable None)
| Some _, None -> c1
| None, Some _ -> c2
| None, None -> None in
@@ -1543,7 +1591,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
let x = id_of_name_using_hdchar (Global.env()) t name in
let ids = ids_of_named_context (named_context env) in
if name == Anonymous then next_ident_away_in_goal x ids else
- if mem_named_context x (named_context env) then
+ if mem_named_context_val x (named_context_val env) then
errorlabstrm "Unification.make_abstraction_core"
(str "The variable " ++ Nameops.pr_id x ++ str " is already declared.")
else
@@ -1551,21 +1599,15 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
in
let likefirst = clause_with_generic_occurrences occs in
let mkvarid () = mkVar id in
- let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) =
+ let compute_dependency _ d (sign,depdecls) =
+ let hyp = get_id d in
match occurrences_of_hyp hyp occs with
| NoOccurrences, InHyp ->
- if indirectly_dependent c d depdecls then
- (* Told explicitly not to abstract over [d], but it is dependent *)
- let id' = indirect_dependency d depdecls in
- errorlabstrm "" (str "Cannot abstract over " ++ Nameops.pr_id id'
- ++ str " without also abstracting or erasing " ++ Nameops.pr_id hyp
- ++ str ".")
- else
- (push_named_context_val d sign,depdecls)
+ (push_named_context_val d sign,depdecls)
| AllOccurrences, InHyp as occ ->
let occ = if likefirst then LikeFirst else AtOccs occ in
let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in
- if Context.eq_named_declaration d newdecl
+ if Context.Named.Declaration.equal d newdecl
&& not (indirectly_dependent c d depdecls)
then
if check_occs && not (in_every_hyp occs)
@@ -1588,8 +1630,12 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
replace_term_occ_modulo occ test mkvarid concl
in
let lastlhyp =
- if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in
- (id,sign,depdecls,lastlhyp,ccl,out test)
+ if List.is_empty depdecls then None else Some (get_id (List.last depdecls)) in
+ let res = match out test with
+ | None -> None
+ | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma))
+ in
+ (id,sign,depdecls,lastlhyp,ccl,res)
with
SubtermUnificationError e ->
raise (PretypeError (env,sigma,CannotUnifyOccurrences e))
@@ -1611,12 +1657,13 @@ type abstraction_request =
| AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Name.t * pending_constr * clause * bool
| AbstractExact of Name.t * constr * types option * clause * bool
-type abstraction_result =
+type 'r abstraction_result =
Names.Id.t * named_context_val *
- Context.named_declaration list * Names.Id.t option *
- types * (Evd.evar_map * constr) option
+ Context.Named.Declaration.t list * Names.Id.t option *
+ types * (constr, 'r) Sigma.sigma option
let make_abstraction env evd ccl abs =
+ let evd = Sigma.to_evar_map evd in
match abs with
| AbstractPattern (from_prefix,check,name,c,occs,check_occs) ->
make_abstraction_core name
@@ -1791,17 +1838,25 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t =
let allow_K = flags.allow_K_in_toplevel_higher_order_unification in
let flags =
if occur_meta_or_existential op || !keyed_unification then
+ (* This is up to delta for subterms w/o metas ... *)
flags
else
(* up to Nov 2014, unification was bypassed on evar/meta-free terms;
now it is called in a minimalistic way, at least to possibly
unify pre-existing non frozen evars of the goal or of the
pattern *)
- set_no_delta_flags flags in
+ set_no_delta_flags flags in
+ let t' = (strip_outer_cast op,t) in
let (evd',cl) =
try
- (* This is up to delta for subterms w/o metas ... *)
- w_unify_to_subterm env evd ~flags (strip_outer_cast op,t)
+ if is_keyed_unification () then
+ try (* First try finding a subterm w/o conversion on open terms *)
+ let flags = set_no_delta_open_flags flags in
+ w_unify_to_subterm env evd ~flags t'
+ with e ->
+ (* If this fails, try with full conversion *)
+ w_unify_to_subterm env evd ~flags t'
+ else w_unify_to_subterm env evd ~flags t'
with PretypeError (env,_,NoOccurrenceFound _) when
allow_K ||
(* w_unify_to_subterm does not go through evars, so
@@ -1828,21 +1883,14 @@ let secondOrderAbstraction env evd flags typ (p, oplist) =
error_wrong_abstraction_type env evd'
(Evd.meta_name evd p) pred typp predtyp;
w_merge env false flags.merge_unify_flags
- (evd',[p,pred,(Conv,TypeProcessed)],[])
-
- (* let evd',metas,evars = *)
- (* try unify_0 env evd' CUMUL flags predtyp typp *)
- (* with NotConvertible -> *)
- (* error_wrong_abstraction_type env evd *)
- (* (Evd.meta_name evd p) pred typp predtyp *)
- (* in *)
- (* w_merge env false flags (evd',(p,pred,(Conv,TypeProcessed))::metas,evars) *)
+ (evd',[p,pred,(Conv,TypeProcessed)],[])
let secondOrderDependentAbstraction env evd flags typ (p, oplist) =
let typp = Typing.meta_type evd p in
let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in
w_merge env false flags.merge_unify_flags
- (evd,[p,pred,(Conv,TypeProcessed)],[])
+ (evd,[p,pred,(Conv,TypeProcessed)],[])
+
let secondOrderAbstractionAlgo dep =
if dep then secondOrderDependentAbstraction else secondOrderAbstraction
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index d5d5caf9..0ad882a9 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -75,15 +75,15 @@ type abstraction_request =
| AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool
val finish_evar_resolution : ?flags:Pretyping.inference_flags ->
- env -> Evd.evar_map -> pending_constr -> Evd.evar_map * constr
+ env -> 'r Sigma.t -> pending_constr -> (constr, 'r) Sigma.sigma
-type abstraction_result =
+type 'r abstraction_result =
Names.Id.t * named_context_val *
- Context.named_declaration list * Names.Id.t option *
- types * (Evd.evar_map * constr) option
+ Context.Named.Declaration.t list * Names.Id.t option *
+ types * (constr, 'r) Sigma.sigma option
-val make_abstraction : env -> Evd.evar_map -> constr ->
- abstraction_request -> abstraction_result
+val make_abstraction : env -> 'r Sigma.t -> constr ->
+ abstraction_request -> 'r abstraction_result
val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 7d86fad9..e281f22d 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -15,6 +15,7 @@ open Environ
open Inductive
open Reduction
open Vm
+open Context.Rel.Declaration
(*******************************************)
(* Calcul de la forme normal d'un terme *)
@@ -23,7 +24,7 @@ open Vm
let crazy_type = mkSet
let decompose_prod env t =
- let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
+ let (name,dom,codom as res) = destProd (whd_all env t) in
match name with
| Anonymous -> (Name (Id.of_string "x"), dom, codom)
| Name _ -> res
@@ -46,12 +47,10 @@ let invert_tag cst tag reloc_tbl =
(* Argggg, ces constructeurs de ... qui commencent a 1*)
let find_rectype_a env c =
- let (t, l) =
- let t = whd_betadeltaiota env c in
- try destApp t with DestKO -> (t,[||]) in
+ let (t, l) = decompose_appvect (whd_all env c) in
match kind_of_term t with
| Ind ind -> (ind, l)
- | _ -> raise Not_found
+ | _ -> assert false
(* Instantiate inductives and parameters in constructor type *)
@@ -59,11 +58,11 @@ let type_constructor mind mib u typ params =
let s = ind_subst mind mib u in
let ctyp = substl s typ in
let ctyp = subst_instance_constr u ctyp in
- let ndecls = Context.rel_context_length mib.mind_params_ctxt in
+ let ndecls = Context.Rel.length mib.mind_params_ctxt in
if Int.equal ndecls 0 then ctyp
else
let _,ctyp = decompose_prod_n_assum ndecls ctyp in
- substl (List.rev (Termops.adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params)))
+ substl (List.rev (adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params)))
ctyp
@@ -140,7 +139,7 @@ and nf_whd env whd typ =
let dom = nf_vtype env (dom p) in
let name = Name (Id.of_string "x") in
let vc = body_of_vfun (nb_rel env) (codom p) in
- let codom = nf_vtype (push_rel (name,None,dom) env) vc in
+ let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) vc in
mkProd(name,dom,codom)
| Vfun f -> nf_fun env f typ
| Vfix(f,None) -> nf_fix env f
@@ -208,11 +207,12 @@ and constr_type_of_idkey env (idkey : Vars.id_key) stk =
in
nf_univ_args ~nb_univs mk env stk
| VarKey id ->
- let (_,_,ty) = lookup_named id env in
+ let open Context.Named.Declaration in
+ let ty = get_type (lookup_named id env) in
nf_stk env (mkVar id) ty stk
| RelKey i ->
let n = (nb_rel env - i) in
- let (_,_,ty) = lookup_rel n env in
+ let ty = get_type (lookup_rel n env) in
nf_stk env (mkRel n) (lift n ty) stk
and nf_stk ?from:(from=0) env c t stk =
@@ -238,7 +238,7 @@ and nf_stk ?from:(from=0) env c t stk =
let params,realargs = Util.Array.chop nparams allargs in
let pT =
hnf_prod_applist env (type_of_ind env (ind,u)) (Array.to_list params) in
- let pT = whd_betadeltaiota env pT in
+ let pT = whd_all env pT in
let dep, p = nf_predicate env (ind,u) mip params (type_of_switch sw) pT in
(* Calcul du type des branches *)
let btypes = build_branches_type env ind mib mip u params dep p in
@@ -266,7 +266,7 @@ and nf_predicate env ind mip params v pT =
let vb = body_of_vfun k f in
let name,dom,codom = decompose_prod env pT in
let dep,body =
- nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
+ nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in
dep, mkLambda(name,dom,body)
| Vfun f, _ ->
let k = nb_rel env in
@@ -276,7 +276,7 @@ and nf_predicate env ind mip params v pT =
let rargs = Array.init n (fun i -> mkRel (n-i)) in
let params = if Int.equal n 0 then params else Array.map (lift n) params in
let dom = mkApp(mkIndU ind,Array.append params rargs) in
- let body = nf_vtype (push_rel (name,None,dom) env) vb in
+ let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) vb in
true, mkLambda(name,dom,body)
| _, _ -> false, nf_val env v crazy_type
@@ -309,10 +309,10 @@ and nf_fun env f typ =
try decompose_prod env typ
with DestKO ->
(* 27/2/13: Turned this into an anomaly *)
- Errors.anomaly
+ CErrors.anomaly
(Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
in
- let body = nf_val (push_rel (name,None,dom) env) vb codom in
+ let body = nf_val (push_rel (LocalAssum (name,dom)) env) vb codom in
mkLambda(name,dom,body)
and nf_fix env f =
diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli
index bdc6c1db..58f5b14e 100644
--- a/pretyping/vnorm.mli
+++ b/pretyping/vnorm.mli
@@ -8,7 +8,6 @@
open Term
open Environ
-open Evd
(** {6 Reduction functions } *)
val cbv_vm : env -> constr -> types -> constr