aboutsummaryrefslogtreecommitdiff
path: root/pretyping
diff options
context:
space:
mode:
authorMaxime Dénès2017-05-25 11:16:35 +0200
committerMaxime Dénès2017-05-25 11:16:35 +0200
commitf2fec63025d933f56dabf114a51720b1aae626c1 (patch)
tree7f729302601fef48e6c59534a7904c7dfb92df2d /pretyping
parent28f8da9489463b166391416de86420c15976522f (diff)
parent94e783390ef9ad9d26a54add2287e0a3e58d1b70 (diff)
Merge PR#402: Uniform attribute handling in interfaces
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/cases.ml174
-rw-r--r--pretyping/cases.mli8
-rw-r--r--pretyping/coercion.ml66
-rw-r--r--pretyping/coercion.mli14
-rw-r--r--pretyping/detyping.ml240
-rw-r--r--pretyping/detyping.mli12
-rw-r--r--pretyping/evarconv.ml6
-rw-r--r--pretyping/evardefine.ml4
-rw-r--r--pretyping/evardefine.mli2
-rw-r--r--pretyping/glob_ops.ml265
-rw-r--r--pretyping/glob_ops.mli7
-rw-r--r--pretyping/miscops.ml2
-rw-r--r--pretyping/patternops.ml60
-rw-r--r--pretyping/pretype_errors.ml2
-rw-r--r--pretyping/pretyping.ml177
-rw-r--r--pretyping/pretyping.mli2
-rw-r--r--pretyping/typing.ml6
-rw-r--r--pretyping/typing.mli2
-rw-r--r--pretyping/unification.ml4
19 files changed, 520 insertions, 533 deletions
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 8a49cd5488..e7b17991e3 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -95,7 +95,7 @@ let msg_may_need_inversion () =
(* Utils *)
let make_anonymous_patvars n =
- List.make n (PatVar (Loc.ghost,Anonymous))
+ List.make n (CAst.make @@ PatVar Anonymous)
(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
@@ -122,7 +122,7 @@ type 'a equation =
{ patterns : cases_pattern list;
rhs : 'a rhs;
alias_stack : Name.t list;
- eqn_loc : Loc.t;
+ eqn_loc : Loc.t option;
used : bool ref }
type 'a matrix = 'a equation list
@@ -178,7 +178,7 @@ and build_glob_pattern args = function
| Top -> args
| MakeConstructor (pci, rh) ->
glob_pattern_of_partial_history
- [PatCstr (Loc.ghost, pci, args, Anonymous)] rh
+ [CAst.make @@ PatCstr (pci, args, Anonymous)] rh
let complete_history = glob_pattern_of_partial_history []
@@ -188,12 +188,12 @@ let pop_history_pattern = function
| Continuation (0, l, Top) ->
Result (List.rev l)
| Continuation (0, l, MakeConstructor (pci, rh)) ->
- feed_history (PatCstr (Loc.ghost,pci,List.rev l,Anonymous)) rh
+ feed_history (CAst.make @@ PatCstr (pci,List.rev l,Anonymous)) rh
| _ ->
anomaly (Pp.str "Constructor not yet filled with its arguments")
let pop_history h =
- feed_history (PatVar (Loc.ghost, Anonymous)) h
+ feed_history (CAst.make @@ PatVar Anonymous) h
(* Builds a continuation expecting [n] arguments and building [ci] applied
to this [n] arguments *)
@@ -251,7 +251,7 @@ type 'a pattern_matching_problem =
tomatch : tomatch_stack;
history : pattern_continuation;
mat : 'a matrix;
- caseloc : Loc.t;
+ caseloc : Loc.t option;
casestyle : case_style;
typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment }
@@ -273,16 +273,16 @@ type 'a pattern_matching_problem =
let rec find_row_ind = function
[] -> None
- | PatVar _ :: l -> find_row_ind l
- | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
+ | { CAst.v = PatVar _ } :: l -> find_row_ind l
+ | { CAst.v = PatCstr(c,_,_) ; loc } :: _ -> Some (loc,c)
let inductive_template evdref env tmloc ind =
let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in
let arsign = inductive_alldecls_env env indu in
let indu = on_snd EInstance.make indu in
let hole_source i = match tmloc with
- | Some loc -> (loc, Evar_kinds.TomatchTypeParameter (ind,i))
- | None -> (Loc.ghost, Evar_kinds.TomatchTypeParameter (ind,i)) in
+ | Some loc -> Loc.tag ~loc @@ Evar_kinds.TomatchTypeParameter (ind,i)
+ | None -> Loc.tag @@ Evar_kinds.TomatchTypeParameter (ind,i) in
let (_,evarl,_) =
List.fold_right
(fun decl (subst,evarl,n) ->
@@ -342,16 +342,16 @@ let unify_tomatch_with_patterns evdref env loc typ pats realnames =
let find_tomatch_tycon evdref env loc = function
(* Try if some 'in I ...' is present and can be used as a constraint *)
- | Some (_,ind,realnal) ->
+ | Some (_,(ind,realnal)) ->
mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal)
| None ->
empty_tycon,None
let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) =
- let loc = Some (loc_of_glob_constr tomatch) in
+ let loc = loc_of_glob_constr tomatch in
let tycon,realnames = find_tomatch_tycon evdref env loc indopt in
let j = typing_fun tycon env evdref tomatch in
- let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !evdref j in
+ let evd, j = Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) env !evdref j in
evdref := evd;
let typ = nf_evar !evdref j.uj_type in
let t =
@@ -360,7 +360,7 @@ let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) =
unify_tomatch_with_patterns evdref env loc typ pats realnames in
(j.uj_val,t)
-let coerce_to_indtype typing_fun evdref env matx tomatchl =
+let coerce_to_indtype typing_fun evdref env matx tomatchl =
let pats = List.map (fun r -> r.patterns) matx in
let matx' = match matrix_transpose pats with
| [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *)
@@ -370,7 +370,7 @@ let coerce_to_indtype typing_fun evdref env matx tomatchl =
(************************************************************************)
(* Utils *)
-let mkExistential env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evdref =
+let mkExistential env ?(src=(Loc.tag Evar_kinds.InternalHole)) evdref =
let e, u = e_new_type_evar env evdref univ_flexible_alg ~src:src in e
let evd_comb2 f evdref x y =
@@ -402,7 +402,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) =
let _ = e_cumul pb.env pb.evdref indt typ in
current
else
- (evd_comb2 (Coercion.inh_conv_coerce_to true Loc.ghost pb.env)
+ (evd_comb2 (Coercion.inh_conv_coerce_to true pb.env)
pb.evdref (make_judge current typ) indt).uj_val in
let sigma = !(pb.evdref) in
(current,try_find_ind pb.env sigma indt names))
@@ -427,9 +427,10 @@ let current_pattern eqn =
| pat::_ -> pat
| [] -> anomaly (Pp.str "Empty list of patterns")
-let alias_of_pat = function
- | PatVar (_,name) -> name
- | PatCstr(_,_,_,name) -> name
+let alias_of_pat = CAst.with_val (function
+ | PatVar name -> name
+ | PatCstr(_,_,name) -> name
+ )
let remove_current_pattern eqn =
match eqn.patterns with
@@ -468,17 +469,17 @@ let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
exception NotAdjustable
-let rec adjust_local_defs loc = function
+let rec adjust_local_defs ?loc = function
| (pat :: pats, LocalAssum _ :: decls) ->
- pat :: adjust_local_defs loc (pats,decls)
+ pat :: adjust_local_defs ?loc (pats,decls)
| (pats, LocalDef _ :: decls) ->
- PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
+ (CAst.make ?loc @@ PatVar Anonymous) :: adjust_local_defs ?loc (pats,decls)
| [], [] -> []
| _ -> raise NotAdjustable
let check_and_adjust_constructor env ind cstrs = function
- | PatVar _ as pat -> pat
- | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
+ | { CAst.v = PatVar _ } as pat -> pat
+ | { CAst.v = PatCstr (((_,i) as cstr),args,alias) ; loc } as pat ->
(* Check it is constructor of the right type *)
let ind' = inductive_of_constructor cstr in
if eq_ind ind' ind then
@@ -488,28 +489,28 @@ let check_and_adjust_constructor env ind cstrs = function
if Int.equal (List.length args) nb_args_constr then pat
else
try
- let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
- in PatCstr (loc, cstr, args', alias)
+ let args' = adjust_local_defs ?loc (args, List.rev ci.cs_args)
+ in CAst.make ?loc @@ PatCstr (cstr, args', alias)
with NotAdjustable ->
- error_wrong_numarg_constructor ~loc env cstr nb_args_constr
+ error_wrong_numarg_constructor ?loc env cstr nb_args_constr
else
(* Try to insert a coercion *)
try
- Coercion.inh_pattern_coerce_to loc env pat ind' ind
+ Coercion.inh_pattern_coerce_to ?loc env pat ind' ind
with Not_found ->
- error_bad_constructor ~loc env cstr ind
+ error_bad_constructor ?loc env cstr ind
let check_all_variables env sigma typ mat =
List.iter
(fun eqn -> match current_pattern eqn with
- | PatVar (_,id) -> ()
- | PatCstr (loc,cstr_sp,_,_) ->
- error_bad_pattern ~loc env sigma cstr_sp typ)
+ | { CAst.v = PatVar id } -> ()
+ | { CAst.v = PatCstr (cstr_sp,_,_); loc } ->
+ error_bad_pattern ?loc env sigma cstr_sp typ)
mat
let check_unused_pattern env eqn =
if not !(eqn.used) then
- raise_pattern_matching_error ~loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns)
+ raise_pattern_matching_error ?loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns)
let set_used_pattern eqn = eqn.used := true
@@ -529,8 +530,8 @@ let occur_in_rhs na rhs =
| Name id -> Id.List.mem id rhs.rhs_vars
let is_dep_patt_in eqn = function
- | PatVar (_,name) -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs
- | PatCstr _ -> true
+ | { CAst.v = PatVar name } -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs
+ | { CAst.v = PatCstr _ } -> true
let mk_dep_patt_row (pats,_,eqn) =
List.map (is_dep_patt_in eqn) pats
@@ -750,7 +751,7 @@ let recover_and_adjust_alias_names 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)
+ (CAst.make @@ PatVar na, decl) :: aux (names,sign)
| _ -> assert false
in
List.split (aux (names,sign))
@@ -967,7 +968,7 @@ let use_unit_judge evd =
evd', j
let add_assert_false_case pb tomatch =
- let pats = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) tomatch in
+ let pats = List.map (fun _ -> CAst.make @@ PatVar Anonymous) tomatch in
let aliasnames =
List.map_filter (function Alias _ | NonDepAlias -> Some Anonymous | _ -> None) tomatch
in
@@ -977,7 +978,7 @@ let add_assert_false_case pb tomatch =
avoid_ids = [];
it = None };
alias_stack = Anonymous::aliasnames;
- eqn_loc = Loc.ghost;
+ eqn_loc = None;
used = ref false } ]
let adjust_impossible_cases pb pred tomatch submat =
@@ -1165,8 +1166,8 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs =
(* Sorting equations by constructor *)
let rec irrefutable env = function
- | PatVar (_,name) -> true
- | PatCstr (_,cstr,args,_) ->
+ | { CAst.v = PatVar name } -> true
+ | { CAst.v = PatCstr (cstr,args,_) } ->
let ind = inductive_of_constructor cstr in
let (_,mip) = Inductive.lookup_mind_specif env ind in
let one_constr = Int.equal (Array.length mip.mind_user_lc) 1 in
@@ -1187,14 +1188,14 @@ let group_equations pb ind current cstrs mat =
let rest = remove_current_pattern eqn in
let pat = current_pattern eqn in
match check_and_adjust_constructor pb.env ind cstrs pat with
- | PatVar (_,name) ->
+ | { CAst.v = PatVar name } ->
(* This is a default clause that we expand *)
for i=1 to Array.length cstrs do
let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in
brs.(i-1) <- (args, name, rest) :: brs.(i-1)
done;
if !only_default == None then only_default := Some true
- | PatCstr (loc,((_,i)),args,name) ->
+ | { CAst.v = PatCstr (((_,i)),args,name) ; loc } ->
(* This is a regular clause *)
only_default := Some false;
brs.(i-1) <- (args, name, rest) :: brs.(i-1)) mat () in
@@ -1540,7 +1541,7 @@ substituer après par les initiaux *)
* and linearizing the _ patterns.
* Syntactic correctness has already been done in astterm *)
let matx_of_eqns env eqns =
- let build_eqn (loc,ids,lpat,rhs) =
+ let build_eqn (loc,(ids,lpat,rhs)) =
let initial_lpat,initial_rhs = lpat,rhs in
let initial_rhs = rhs in
let rhs =
@@ -1634,11 +1635,11 @@ let rec list_assoc_in_triple x = function
* similarly for each ti.
*)
-let abstract_tycon loc env evdref subst tycon extenv t =
+let abstract_tycon ?loc env evdref subst tycon extenv t =
let t = nf_betaiota !evdref t in (* it helps in some cases to remove K-redex*)
let src = match EConstr.kind !evdref t with
- | Evar (evk,_) -> (loc,Evar_kinds.SubEvar evk)
- | _ -> (loc,Evar_kinds.CasesType true) in
+ | Evar (evk,_) -> (Loc.tag ?loc @@ Evar_kinds.SubEvar evk)
+ | _ -> (Loc.tag ?loc @@ Evar_kinds.CasesType true) in
let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv !evdref subst t in
(* We traverse the type T of the original problem Xi looking for subterms
that match the non-constructor part of the constraints (this part
@@ -1692,7 +1693,7 @@ let abstract_tycon loc env evdref subst tycon extenv t =
in
aux (0,extenv,subst0) t0
-let build_tycon loc env tycon_env s subst tycon extenv evdref t =
+let build_tycon ?loc env tycon_env s subst tycon extenv evdref t =
let t,tt = match t with
| None ->
(* This is the situation we are building a return predicate and
@@ -1700,10 +1701,10 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t =
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
+ e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase) in
(lift (n'-n) impossible_case_type, mkSort u)
| Some t ->
- let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in
+ let t = abstract_tycon ?loc tycon_env evdref subst tycon extenv t in
let evd,tt = Typing.type_of extenv !evdref t in
evdref := evd;
(t,tt) in
@@ -1724,16 +1725,16 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t =
let build_inversion_problem loc env sigma tms t =
let make_patvar t (subst,avoid) =
let id = next_name_away (named_hd env sigma t Anonymous) avoid in
- PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in
+ CAst.make @@ PatVar (Name id), ((id,t)::subst, id::avoid) in
let rec reveal_pattern t (subst,avoid as acc) =
match EConstr.kind sigma (whd_all env sigma t) with
- | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc
+ | Construct (cstr,u) -> CAst.make (PatCstr (cstr,[],Anonymous)), acc
| App (f,v) when isConstruct sigma f ->
let cstr,u = destConstruct sigma f in
let n = constructor_nrealargs_env env cstr in
let l = List.lastn n (Array.to_list v) in
let l,acc = List.fold_map' reveal_pattern l acc in
- PatCstr (Loc.ghost,cstr,l,Anonymous), acc
+ CAst.make (PatCstr (cstr,l,Anonymous)), acc
| _ -> make_patvar t acc in
let rec aux n env acc_sign tms acc =
match tms with
@@ -1791,7 +1792,7 @@ let build_inversion_problem loc env sigma tms t =
let main_eqn =
{ patterns = patl;
alias_stack = [];
- eqn_loc = Loc.ghost;
+ eqn_loc = None;
used = ref false;
rhs = { rhs_env = pb_env;
(* we assume all vars are used; in practice we discard dependent
@@ -1809,9 +1810,9 @@ let build_inversion_problem loc env sigma tms t =
(* No need for a catch all clause *)
[]
else
- [ { patterns = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) patl;
+ [ { patterns = List.map (fun _ -> CAst.make @@ PatVar Anonymous) patl;
alias_stack = [];
- eqn_loc = Loc.ghost;
+ eqn_loc = None;
used = ref false;
rhs = { rhs_env = pb_env;
rhs_vars = [];
@@ -1832,7 +1833,7 @@ let build_inversion_problem loc env sigma tms t =
mat = main_eqn :: catch_all_eqn;
caseloc = loc;
casestyle = RegularStyle;
- typing_function = build_tycon loc env pb_env s subst} in
+ typing_function = build_tycon ?loc env pb_env s subst} in
let pred = (compile pb).uj_val in
(!evdref,pred)
@@ -1857,8 +1858,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
| 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
+ | Some (loc,_) ->
+ user_err ?loc
(str"Unexpected type annotation for a term of non inductive type."))
| IsInd (term,IndType(indf,realargs),_) ->
let indf' = if dolift then lift_inductive_family n indf else indf in
@@ -1868,9 +1869,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in
let realnal =
match t with
- | Some (loc,ind',realnal) ->
+ | Some (loc,(ind',realnal)) ->
if not (eq_ind ind ind') then
- user_err ~loc (str "Wrong inductive type.");
+ user_err ?loc (str "Wrong inductive type.");
if not (Int.equal nrealargs_ctxt (List.length realnal)) then
anomaly (Pp.str "Ill-formed 'in' clause in cases");
List.rev realnal
@@ -1885,10 +1886,10 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
| _ -> assert false
in List.rev (buildrec 0 (tomatchl,tmsign))
-let inh_conv_coerce_to_tycon loc env evdref j tycon =
+let inh_conv_coerce_to_tycon ?loc env evdref j tycon =
match tycon with
| Some p ->
- let (evd',j) = Coercion.inh_conv_coerce_to true loc env !evdref j p in
+ let (evd',j) = Coercion.inh_conv_coerce_to ?loc true env !evdref j p in
evdref := evd';
j
| None -> j
@@ -1971,7 +1972,7 @@ let noccur_with_meta sigma n m term =
in
try (occur_rec n term; true) with LocalOccur -> false
-let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
+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
@@ -2002,7 +2003,7 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
| None ->
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
+ new_type_evar env sigma univ_flexible_alg ~src:(Loc.tag ?loc @@ Evar_kinds.CasesType false) in
let sigma = Sigma.to_evar_map sigma in
sigma, t
in
@@ -2064,23 +2065,24 @@ 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 false),
+let hole = CAst.make @@
+ GHole (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 =
- match pat with
- | PatVar (l,name) ->
+ let loc = pat.CAst.loc in
+ match pat.CAst.v with
+ | PatVar name ->
let name, avoid = match name with
Name n -> name, avoid
| Anonymous ->
let previd, id = prime avoid (Name (Id.of_string "wildcard")) in
Name id, id :: avoid
in
- (PatVar (l, name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty,
+ ((CAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty,
(List.map (fun x -> mkRel 1) realargs), 1, avoid)
- | PatCstr (l,((_, i) as cstr),args,alias) ->
+ | PatCstr (((_, i) as cstr),args,alias) ->
let cind = inductive_of_constructor cstr in
let IndType (indf, _) =
try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty)
@@ -2089,7 +2091,7 @@ let constr_of_pat env evdref arsign pat avoid =
in
let (ind,u), params = dest_ind_family indf in
let params = List.map EConstr.of_constr params in
- if not (eq_ind ind cind) then error_bad_constructor ~loc:l env cstr ind;
+ if not (eq_ind ind cind) then error_bad_constructor ?loc env cstr ind;
let cstrs = get_constructors env indf in
let ci = cstrs.(i-1) in
let nb_args_constr = ci.cs_nargs in
@@ -2109,7 +2111,7 @@ let constr_of_pat env evdref arsign pat avoid =
in
let args = List.rev args in
let patargs = List.rev patargs in
- let pat' = PatCstr (l, cstr, patargs, alias) in
+ let pat' = CAst.make ?loc @@ PatCstr (cstr, patargs, alias) in
let cstr = mkConstructU (on_snd EInstance.make ci.cs_cstr) in
let app = applist (cstr, List.map (lift (List.length sign)) params) in
let app = applist (app, args) in
@@ -2165,21 +2167,21 @@ let vars_of_ctx sigma ctx =
match decl with
| LocalDef (na,t',t) when is_topvar sigma t' ->
prev,
- (GApp (Loc.ghost,
- (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)),
- [hole; GVar (Loc.ghost, prev)])) :: vars
+ (CAst.make @@ GApp (
+ (CAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)),
+ [hole; CAst.make @@ GVar prev])) :: vars
| _ ->
match RelDecl.get_name decl with
Anonymous -> invalid_arg "vars_of_ctx"
- | Name n -> n, GVar (Loc.ghost, n) :: vars)
+ | Name n -> n, (CAst.make @@ GVar n) :: vars)
ctx (Id.of_string "vars_of_ctx_error", [])
in List.rev y
let rec is_included x y =
- match x, y with
+ match CAst.(x.v, y.v) with
| PatVar _, _ -> true
| _, PatVar _ -> true
- | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias') ->
+ | PatCstr ((_, i), args, alias), PatCstr ((_, i'), args', alias') ->
if Int.equal i i' then List.for_all2 is_included args args'
else false
@@ -2294,13 +2296,13 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) 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
+ let bref = CAst.make @@ GVar branch_name in
match vars_of_ctx !evdref rhs_rels with
[] -> bref
- | l -> GApp (Loc.ghost, bref, l)
+ | l -> CAst.make @@ GApp (bref, l)
in
let branch = match ineqs with
- Some _ -> GApp (Loc.ghost, branch, [ hole ])
+ Some _ -> CAst.make @@ GApp (branch, [ hole ])
| None -> branch
in
incr i;
@@ -2443,7 +2445,7 @@ let context_of_arsign l =
l ([], 0)
in x
-let compile_program_cases loc style (typing_function, evdref) tycon env
+let compile_program_cases ?loc style (typing_function, evdref) tycon env
(predopt, tomatchl, eqns) =
let typing_fun tycon env = function
| Some t -> typing_function tycon env evdref t
@@ -2550,9 +2552,9 @@ 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) =
+let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) =
if predopt == None && Flags.is_program_mode () && Program.is_program_cases () then
- compile_program_cases loc style (typing_fun, evdref)
+ compile_program_cases ?loc style (typing_fun, evdref)
tycon env (predopt, tomatchl, eqns)
else
@@ -2569,7 +2571,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
with the type of arguments to match; if none is provided, we
build alternative possible predicates *)
let arsign = extract_arity_signature env tomatchs tomatchl in
- let preds = prepare_predicate loc typing_fun env !evdref tomatchs arsign tycon predopt in
+ let preds = prepare_predicate ?loc typing_fun env !evdref tomatchs arsign tycon predopt in
let compile_for_one_predicate (sigma,nal,pred) =
(* We push the initial terms to match and push their alias to rhs' envs *)
@@ -2619,7 +2621,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
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
+ let j = inh_conv_coerce_to_tycon ?loc env myevdref j tycon in
evdref := !myevdref;
j in
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index 6c2b5bf68b..b16342db4b 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -38,7 +38,7 @@ val irrefutable : env -> cases_pattern -> bool
(** {6 Compilation primitive. } *)
val compile_cases :
- Loc.t -> case_style ->
+ ?loc:Loc.t -> case_style ->
(type_constraint -> env -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref ->
type_constraint ->
env -> glob_constr option * tomatch_tuples * cases_clauses ->
@@ -65,7 +65,7 @@ type 'a equation =
{ patterns : cases_pattern list;
rhs : 'a rhs;
alias_stack : Name.t list;
- eqn_loc : Loc.t;
+ eqn_loc : Loc.t option;
used : bool ref }
type 'a matrix = 'a equation list
@@ -106,14 +106,14 @@ type 'a pattern_matching_problem =
tomatch : tomatch_stack;
history : pattern_continuation;
mat : 'a matrix;
- caseloc : Loc.t;
+ caseloc : Loc.t option;
casestyle : case_style;
typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment }
val compile : 'a pattern_matching_problem -> unsafe_judgment
-val prepare_predicate : Loc.t ->
+val prepare_predicate : ?loc:Loc.t ->
(Evarutil.type_constraint ->
Environ.env -> Evd.evar_map ref -> glob_constr -> unsafe_judgment) ->
Environ.env ->
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index e6c0075c5b..98a00f4332 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -74,24 +74,25 @@ let apply_coercion_args env evd check isproj argl funj =
!evdref, res
(* appliquer le chemin de coercions de patterns p *)
-let apply_pattern_coercion loc pat p =
+let apply_pattern_coercion ?loc pat p =
List.fold_left
(fun pat (co,n) ->
- let f i = if i<n then Glob_term.PatVar (loc, Anonymous) else pat in
- Glob_term.PatCstr (loc, co, List.init (n+1) f, Anonymous))
+ let f i =
+ if i<n then (CAst.make ?loc @@ Glob_term.PatVar Anonymous) else pat in
+ CAst.make ?loc @@ Glob_term.PatCstr (co, List.init (n+1) f, Anonymous))
pat p
(* raise Not_found if no coercion found *)
-let inh_pattern_coerce_to loc env pat ind1 ind2 =
+let inh_pattern_coerce_to ?loc env pat ind1 ind2 =
let p = lookup_pattern_path_between env (ind1,ind2) in
- apply_pattern_coercion loc pat p
+ apply_pattern_coercion ?loc pat p
(* Program coercions *)
open Program
-let make_existential loc ?(opaque = not (get_proofs_transparency ())) env evdref c =
- let src = (loc, Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in
+let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) env evdref c =
+ let src = Loc.tag ?loc (Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in
Evarutil.e_new_evar env evdref ~src c
let app_opt env evdref f t =
@@ -140,7 +141,7 @@ let mu env evdref t =
| None -> (None, v)
in aux t
-and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr)
+and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr)
: (EConstr.constr -> EConstr.constr) option
=
let open Context.Rel.Declaration in
@@ -181,7 +182,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr)
let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in
let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in
let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in
- let evar = make_existential loc env evdref eq in
+ let evar = make_existential ?loc env evdref eq in
let eq_app x = papp evdref coq_eq_rect
[| eqT; hdx; pred; x; hdy; evar|]
in
@@ -324,7 +325,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr)
Some
(fun x ->
let cx = app_opt env evdref c x in
- let evar = make_existential loc env evdref (mkApp (p, [| cx |]))
+ let evar = make_existential ?loc env evdref (mkApp (p, [| cx |]))
in
(papp evdref sig_intro [| u; p; cx; evar |]))
| None ->
@@ -338,9 +339,9 @@ let app_coercion env evdref coercion v =
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 coerce_itf ?loc env evd v t c1 =
let evdref = ref evd in
- let coercion = coerce loc env evdref t c1 in
+ let coercion = coerce ?loc env evdref t c1 in
let t = Option.map (app_coercion env evdref coercion) v in
!evdref, t
@@ -408,16 +409,16 @@ let type_judgment env sigma j =
| Sort s -> {utj_val = j.uj_val; utj_type = ESorts.kind sigma s }
| _ -> error_not_a_type env sigma j
-let inh_tosort_force loc env evd j =
+let inh_tosort_force ?loc env evd j =
try
let t,p = lookup_path_to_sort_from env evd j.uj_type in
let evd,j1 = apply_coercion env evd p j t in
let j2 = on_judgment_type (whd_evar evd) j1 in
(evd,type_judgment env evd j2)
with Not_found | NoCoercion ->
- error_not_a_type ~loc env evd j
+ error_not_a_type ?loc env evd j
-let inh_coerce_to_sort loc env evd j =
+let inh_coerce_to_sort ?loc env evd j =
let typ = whd_all env evd j.uj_type in
match EConstr.kind evd typ with
| Sort s -> (evd,{ utj_val = j.uj_val; utj_type = ESorts.kind evd s })
@@ -425,9 +426,9 @@ let inh_coerce_to_sort loc env evd j =
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
+ inh_tosort_force ?loc env evd j
-let inh_coerce_to_base loc env evd j =
+let inh_coerce_to_base ?loc env evd j =
if Flags.is_program_mode () then
let evdref = ref evd in
let ct, typ' = mu env evdref j.uj_type in
@@ -437,7 +438,7 @@ let inh_coerce_to_base loc env evd j =
in !evdref, res
else (evd, j)
-let inh_coerce_to_prod loc env evd t =
+let inh_coerce_to_prod ?loc env evd t =
if Flags.is_program_mode () then
let evdref = ref evd in
let _, typ' = mu env evdref t in
@@ -464,7 +465,7 @@ let inh_coerce_to_fail env evd rigidonly v t c1 =
try (the_conv_x_leq env t' c1 evd, v')
with UnableToUnify _ -> raise NoCoercion
-let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
+let rec inh_conv_coerce_to_fail ?loc env evd rigidonly v t c1 =
try (the_conv_x_leq env t c1 evd, v)
with UnableToUnify (best_failed_evd,e) ->
try inh_coerce_to_fail env evd rigidonly v t c1
@@ -486,49 +487,50 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
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
+ inh_conv_coerce_to_fail ?loc env1 evd rigidonly
(Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
let v1 = Option.get v1 in
let v2 = Option.map (fun v -> beta_applist evd' (lift 1 v,[v1])) v in
let t2 = match v2 with
| None -> subst_term evd' v1 t2
| Some v2 -> Retyping.get_type_of env1 evd' v2 in
- let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in
+ let (evd'',v2') = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in
(evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2')
| _ -> raise (NoCoercionNoUnifier (best_failed_evd,e))
(* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
-let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t =
+let inh_conv_coerce_to_gen ?loc resolve_tc rigidonly env evd cj t =
let (evd', val') =
try
- inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t
+ inh_conv_coerce_to_fail ?loc env evd rigidonly (Some cj.uj_val) cj.uj_type t
with NoCoercionNoUnifier (best_failed_evd,e) ->
try
if Flags.is_program_mode () then
- coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
+ coerce_itf ?loc env evd (Some cj.uj_val) cj.uj_type t
else raise NoSubtacCoercion
with
| NoSubtacCoercion when not resolve_tc || not !use_typeclasses_for_conversion ->
- error_actual_type ~loc env best_failed_evd cj t e
+ error_actual_type ?loc env best_failed_evd cj t e
| NoSubtacCoercion ->
let evd' = saturate_evd env evd in
try
if evd' == evd then
- error_actual_type ~loc env best_failed_evd cj t e
+ error_actual_type ?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
+ inh_conv_coerce_to_fail ?loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t
with NoCoercionNoUnifier (_evd,_error) ->
- error_actual_type ~loc env best_failed_evd cj t e
+ error_actual_type ?loc env best_failed_evd cj t e
in
let val' = match val' with Some v -> v | None -> assert(false) in
(evd',{ uj_val = val'; uj_type = t })
-let inh_conv_coerce_to resolve_tc = inh_conv_coerce_to_gen resolve_tc false
-let inh_conv_coerce_rigid_to resolve_tc = inh_conv_coerce_to_gen resolve_tc true
+let inh_conv_coerce_to ?loc resolve_tc = inh_conv_coerce_to_gen ?loc resolve_tc false
-let inh_conv_coerces_to loc env evd t t' =
+let inh_conv_coerce_rigid_to ?loc resolve_tc = inh_conv_coerce_to_gen resolve_tc ?loc true
+
+let inh_conv_coerces_to ?loc env evd t t' =
try
- fst (inh_conv_coerce_to_fail loc env evd true None t t')
+ fst (inh_conv_coerce_to_fail ?loc env evd true None t t')
with NoCoercion ->
evd (* Maybe not enough information to unify *)
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
index ea3d3f0fa1..ab1f6c110f 100644
--- a/pretyping/coercion.mli
+++ b/pretyping/coercion.mli
@@ -25,17 +25,17 @@ val inh_app_fun : bool ->
(** [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
inserts a coercion into [j], if needed, in such a way it gets as
type a sort; it fails if no coercion is applicable *)
-val inh_coerce_to_sort : Loc.t ->
+val inh_coerce_to_sort : ?loc:Loc.t ->
env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment
(** [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it
inserts a coercion into [j], if needed, in such a way it gets as
type its base type (the notion depends on the coercion system) *)
-val inh_coerce_to_base : Loc.t ->
+val inh_coerce_to_base : ?loc:Loc.t ->
env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
(** [inh_coerce_to_prod env isevars t] coerces [t] to a product type *)
-val inh_coerce_to_prod : Loc.t ->
+val inh_coerce_to_prod : ?loc:Loc.t ->
env -> evar_map -> types -> evar_map * types
(** [inh_conv_coerce_to resolve_tc Loc.t env isevars j t] coerces [j] to an
@@ -43,20 +43,20 @@ val inh_coerce_to_prod : Loc.t ->
a way [t] and [j.uj_type] are convertible; it fails if no coercion is
applicable. resolve_tc=false disables resolving type classes (as the last
resort before failing) *)
-val inh_conv_coerce_to : bool -> Loc.t ->
+val inh_conv_coerce_to : ?loc:Loc.t -> bool ->
env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment
-val inh_conv_coerce_rigid_to : bool -> Loc.t ->
+val inh_conv_coerce_rigid_to : ?loc:Loc.t -> bool ->
env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment
(** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
is coercible to an object of type [t'] adding evar constraints if needed;
it fails if no coercion exists *)
-val inh_conv_coerces_to : Loc.t ->
+val inh_conv_coerces_to : ?loc:Loc.t ->
env -> evar_map -> types -> types -> evar_map
(** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
pattern [pat] typed in [ind1] into a pattern typed in [ind2];
raises [Not_found] if no coercion found *)
val inh_pattern_coerce_to :
- Loc.t -> env -> cases_pattern -> inductive -> inductive -> cases_pattern
+ ?loc:Loc.t -> env -> cases_pattern -> inductive -> inductive -> cases_pattern
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 0d798b4d94..92359420e9 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -28,8 +28,6 @@ open Misctypes
open Decl_kinds
open Context.Named.Declaration
-let dl = Loc.ghost
-
(** Should we keep details of universes during detyping ? *)
let print_universes = Flags.univ_print
@@ -69,14 +67,14 @@ let isomorphic_to_tuple lc = Int.equal (Array.length lc) 1
let encode_bool r =
let (x,lc) = encode_inductive r in
if not (has_two_constructors lc) then
- user_err ~loc:(loc_of_reference r) ~hdr:"encode_if"
+ user_err ?loc:(loc_of_reference r) ~hdr:"encode_if"
(str "This type has not exactly two constructors.");
x
let encode_tuple r =
let (x,lc) = encode_inductive r in
if not (isomorphic_to_tuple lc) then
- user_err ~loc:(loc_of_reference r) ~hdr:"encode_tuple"
+ user_err ?loc:(loc_of_reference r) ~hdr:"encode_tuple"
(str "This type cannot be seen as a tuple type.");
x
@@ -284,7 +282,7 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c =
(avoid', add_name_opt na' body t env) sigma c
let rec build_tree na isgoal e sigma ci cl =
- let mkpat n rhs pl = PatCstr(dl,(ci.ci_ind,n+1),pl,update_name sigma na rhs) in
+ let mkpat n rhs pl = CAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in
let cnl = ci.ci_pp_info.cstr_tags in
let cna = ci.ci_cstr_nargs in
List.flatten
@@ -307,7 +305,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with
List.map (fun (hd,rest) -> pat::hd,rest) lines)
clauses)
| _ ->
- let pat = PatVar(dl,update_name sigma na rhs) in
+ let pat = CAst.make @@ PatVar(update_name sigma na rhs) in
let mat = align_tree nal isgoal rhs sigma in
List.map (fun (hd,rest) -> pat::hd,rest) mat
@@ -330,20 +328,20 @@ let is_nondep_branch sigma c l =
let extract_nondep_branches test c b l =
let rec strip l r =
- match r,l with
- | r, [] -> r
- | GLambda (_,_,_,_,t), false::l -> strip l t
- | GLetIn (_,_,_,_,t), true::l -> strip l t
+ match r.CAst.v, l with
+ | r', [] -> r
+ | GLambda (_,_,_,t), false::l -> strip l t
+ | GLetIn (_,_,_,t), true::l -> strip l t
(* FIXME: do we need adjustment? *)
| _,_ -> assert false in
if test c l then Some (strip l b) else None
let it_destRLambda_or_LetIn_names l c =
let rec aux l nal c =
- match c, l with
+ match c.CAst.v, l with
| _, [] -> (List.rev nal,c)
- | GLambda (_,na,_,_,c), false::l -> aux l (na::nal) c
- | GLetIn (_,na,_,_,c), true::l -> aux l (na::nal) c
+ | GLambda (na,_,_,c), false::l -> aux l (na::nal) c
+ | GLetIn (na,_,_,c), true::l -> aux l (na::nal) c
| _, true::l -> (* let-expansion *) aux l (Anonymous :: nal) c
| _, false::l ->
(* eta-expansion *)
@@ -354,11 +352,11 @@ let it_destRLambda_or_LetIn_names l c =
x
in
let x = next (free_glob_vars c) in
- let a = GVar (dl,x) in
+ let a = CAst.make @@ GVar x in
aux l (Name x :: nal)
(match c with
- | GApp (loc,p,l) -> GApp (loc,p,l@[a])
- | _ -> (GApp (dl,c,[a])))
+ | { loc; CAst.v = GApp (p,l) } -> CAst.make ?loc @@ GApp (p,l@[a])
+ | _ -> CAst.make @@ GApp (c,[a]))
in aux l [] c
let detype_case computable detype detype_eqns testdep avoid data p c bl =
@@ -374,12 +372,12 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
| None -> Anonymous, None, None
| Some p ->
let nl,typ = it_destRLambda_or_LetIn_names k p in
- let n,typ = match typ with
- | GLambda (_,x,_,t,c) -> x, c
+ let n,typ = match typ.CAst.v with
+ | GLambda (x,_,t,c) -> x, c
| _ -> Anonymous, typ in
let aliastyp =
if List.for_all (Name.equal Anonymous) nl then None
- else Some (dl,indsp,nl) in
+ else Some (Loc.tag (indsp,nl)) in
n, aliastyp, Some typ
in
let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in
@@ -401,20 +399,20 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
| LetStyle, None ->
let bl' = Array.map detype bl in
let (nal,d) = it_destRLambda_or_LetIn_names constagsl.(0) bl'.(0) in
- GLetTuple (dl,nal,(alias,pred),tomatch,d)
+ GLetTuple (nal,(alias,pred),tomatch,d)
| IfStyle, None ->
let bl' = Array.map detype bl in
let nondepbrs =
Array.map3 (extract_nondep_branches testdep) bl bl' constagsl in
if Array.for_all ((!=) None) nondepbrs then
- GIf (dl,tomatch,(alias,pred),
+ GIf (tomatch,(alias,pred),
Option.get nondepbrs.(0),Option.get nondepbrs.(1))
else
let eqnl = detype_eqns constructs constagsl bl in
- GCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl)
+ GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl)
| _ ->
let eqnl = detype_eqns constructs constagsl bl in
- GCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl)
+ GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl)
let detype_sort sigma = function
| Prop Null -> GProp
@@ -424,7 +422,7 @@ let detype_sort sigma = function
(if !print_universes
then
let u = Pp.string_of_ppcmds (Univ.Universe.pr_with (Termops.pr_evd_level sigma) u) in
- [dl, Name.mk_name (Id.of_string_soft u)]
+ [Loc.tag @@ Name.mk_name (Id.of_string_soft u)]
else [])
type binder_kind = BProd | BLambda | BLetIn
@@ -432,37 +430,37 @@ type binder_kind = BProd | BLambda | BLetIn
(**********************************************************************)
(* Main detyping function *)
-let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable"))
+let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable"))
let set_detype_anonymous f = detype_anonymous := f
let detype_level sigma l =
let l = Pp.string_of_ppcmds (Termops.pr_evd_level sigma l) in
- GType (Some (dl, Name.mk_name (Id.of_string_soft l)))
+ GType (Some (Loc.tag @@ Name.mk_name (Id.of_string_soft l)))
let detype_instance sigma l =
let l = EInstance.kind sigma l in
if Univ.Instance.is_empty l then None
else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l)))
-let rec detype flags avoid env sigma t =
+let rec detype flags avoid env sigma t = CAst.make @@
match EConstr.kind sigma (collapse_appl sigma t) with
| Rel n ->
(try match lookup_name_of_rel n (fst env) with
- | Name id -> GVar (dl, id)
- | Anonymous -> !detype_anonymous dl n
+ | Name id -> GVar id
+ | Anonymous -> (!detype_anonymous n).CAst.v
with Not_found ->
let s = "_UNBOUND_REL_"^(string_of_int n)
- in GVar (dl, Id.of_string s))
+ in GVar (Id.of_string s))
| Meta n ->
(* Meta in constr are not user-parsable and are mapped to Evar *)
(* using numbers to be unparsable *)
- GEvar (dl, Id.of_string ("M" ^ string_of_int n), [])
+ GEvar (Id.of_string ("M" ^ string_of_int n), [])
| Var id ->
- (try let _ = Global.lookup_named id in GRef (dl, VarRef id, None)
- with Not_found -> GVar (dl, id))
- | Sort s -> GSort (dl,detype_sort sigma (ESorts.kind sigma s))
+ (try let _ = Global.lookup_named id in GRef (VarRef id, None)
+ with Not_found -> GVar id)
+ | Sort s -> GSort (detype_sort sigma (ESorts.kind sigma s))
| Cast (c1,REVERTcast,c2) when not !Flags.raw_print ->
- detype flags avoid env sigma c1
+ (detype flags avoid env sigma c1).CAst.v
| Cast (c1,k,c2) ->
let d1 = detype flags avoid env sigma c1 in
let d2 = detype flags avoid env sigma c2 in
@@ -471,34 +469,34 @@ let rec detype flags avoid env sigma t =
| NATIVEcast -> CastNative d2
| _ -> CastConv d2
in
- GCast(dl,d1,cast)
+ GCast(d1,cast)
| Prod (na,ty,c) -> detype_binder flags BProd avoid env sigma na None ty c
| Lambda (na,ty,c) -> detype_binder flags BLambda avoid env sigma na None ty c
| LetIn (na,b,ty,c) -> detype_binder flags BLetIn avoid env sigma na (Some b) ty c
| App (f,args) ->
let mkapp f' args' =
- match f' with
- | GApp (dl',f',args'') ->
- GApp (dl,f',args''@args')
- | _ -> GApp (dl,f',args')
+ match f'.CAst.v with
+ | GApp (f',args'') ->
+ GApp (f',args''@args')
+ | _ -> GApp (f',args')
in
mkapp (detype flags avoid env sigma f)
(Array.map_to_list (detype flags avoid env sigma) args)
- | Const (sp,u) -> GRef (dl, ConstRef sp, detype_instance sigma u)
+ | Const (sp,u) -> GRef (ConstRef sp, detype_instance sigma u)
| Proj (p,c) ->
let noparams () =
let pb = Environ.lookup_projection p (snd env) in
let pars = pb.Declarations.proj_npars in
- let hole = GHole(Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in
+ let hole = CAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in
let args = List.make pars hole in
- GApp (dl, GRef (dl, ConstRef (Projection.constant p), None),
+ GApp (CAst.make @@ GRef (ConstRef (Projection.constant p), None),
(args @ [detype flags avoid env sigma c]))
in
if fst flags || !Flags.in_debugger || !Flags.in_toplevel then
try noparams ()
with _ ->
(* lax mode, used by debug printers only *)
- GApp (dl, GRef (dl, ConstRef (Projection.constant p), None),
+ GApp (CAst.make @@ GRef (ConstRef (Projection.constant p), None),
[detype flags avoid env sigma c])
else
if print_primproj_compatibility () && Projection.unfolded p then
@@ -516,12 +514,12 @@ let rec detype flags avoid env sigma t =
substl (c :: List.rev args) body'
with Retyping.RetypeError _ | Not_found ->
anomaly (str"Cannot detype an unfolded primitive projection.")
- in detype flags avoid env sigma c'
+ in (detype flags avoid env sigma c').CAst.v
else
if print_primproj_params () then
try
let c = Retyping.expand_projection (snd env) sigma p c [] in
- detype flags avoid env sigma c
+ (detype flags avoid env sigma c).CAst.v
with Retyping.RetypeError _ -> noparams ()
else noparams ()
@@ -548,12 +546,12 @@ let rec detype flags avoid env sigma t =
Id.of_string ("X" ^ string_of_int (Evar.repr evk)),
(Array.map_to_list (fun c -> (Id.of_string "__",c)) cl)
in
- GEvar (dl,id,
+ GEvar (id,
List.map (on_snd (detype flags avoid env sigma)) l)
| Ind (ind_sp,u) ->
- GRef (dl, IndRef ind_sp, detype_instance sigma u)
+ GRef (IndRef ind_sp, detype_instance sigma u)
| Construct (cstr_sp,u) ->
- GRef (dl, ConstructRef cstr_sp, detype_instance sigma u)
+ GRef (ConstructRef cstr_sp, detype_instance sigma u)
| Case (ci,p,c,bl) ->
let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in
detype_case comp (detype flags avoid env sigma)
@@ -576,7 +574,7 @@ and detype_fix flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) =
let v = Array.map3
(fun c t i -> share_names flags (i+1) [] def_avoid def_env sigma c (lift n t))
bodies tys vn in
- GRec(dl,GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi),
+ GRec(GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi),
Array.map (fun (bl,_,_) -> bl) v,
Array.map (fun (_,_,ty) -> ty) v,
Array.map (fun (_,bd,_) -> bd) v)
@@ -592,7 +590,7 @@ and detype_cofix flags avoid env sigma n (names,tys,bodies) =
let v = Array.map2
(fun c t -> share_names flags 0 [] def_avoid def_env sigma c (lift ntys t))
bodies tys in
- GRec(dl,GCoFix n,Array.of_list (List.rev lfi),
+ GRec(GCoFix n,Array.of_list (List.rev lfi),
Array.map (fun (bl,_,_) -> bl) v,
Array.map (fun (_,_,ty) -> ty) v,
Array.map (fun (_,bd,_) -> bd) v)
@@ -637,7 +635,7 @@ and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl =
try
if !Flags.raw_print || not (reverse_matching ()) then raise Exit;
let mat = build_tree Anonymous (snd flags) (avoid,env) sigma ci bl in
- List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype flags avoid env sigma c))
+ List.map (fun (pat,((avoid,env),c)) -> Loc.tag ([],[pat],detype flags avoid env sigma c))
mat
with e when CErrors.noncritical e ->
Array.to_list
@@ -646,17 +644,17 @@ and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl =
and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs branch =
let make_pat x avoid env b body ty ids =
if force_wildcard () && noccurn sigma 1 b then
- PatVar (dl,Anonymous),avoid,(add_name Anonymous body ty env),ids
+ CAst.make @@ PatVar Anonymous,avoid,(add_name Anonymous body ty env),ids
else
let flag = if isgoal then RenamingForGoal else RenamingForCasesPattern (fst env,b) in
let na,avoid' = compute_displayed_name_in sigma flag avoid x b in
- PatVar (dl,na),avoid',(add_name na body ty env),add_vname ids na
+ CAst.make (PatVar na),avoid',(add_name na body ty env),add_vname ids na
in
let rec buildrec ids patlist avoid env l b =
match EConstr.kind sigma b, l with
- | _, [] ->
- (dl, Id.Set.elements ids,
- [PatCstr(dl, constr, List.rev patlist,Anonymous)],
+ | _, [] -> Loc.tag @@
+ (Id.Set.elements ids,
+ [CAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)],
detype flags avoid env sigma b)
| Lambda (x,t,b), false::l ->
let pat,new_avoid,new_env,new_ids = make_pat x avoid env b None t ids in
@@ -670,7 +668,7 @@ and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs bran
buildrec ids patlist avoid env l c
| _, true::l ->
- let pat = PatVar (dl,Anonymous) in
+ let pat = CAst.make @@ PatVar Anonymous in
buildrec ids (pat::patlist) avoid env l b
| _, false::l ->
@@ -692,14 +690,14 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c =
| _ -> compute_displayed_name_in sigma flag avoid na c in
let r = detype flags avoid' (add_name na' body ty env) sigma c in
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)
+ | BProd -> GProd (na',Explicit,detype (lax,false) avoid env sigma ty, r)
+ | BLambda -> GLambda (na',Explicit,detype (lax,false) avoid env sigma ty, 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 t = if s != InProp && not !Flags.raw_print then None else Some (detype (lax,false) avoid env sigma ty) in
- GLetIn (dl, na', c, t, r)
+ GLetIn (na', c, t, r)
let detype_rel_context ?(lax=false) where avoid env sigma sign =
let where = Option.map (fun c -> EConstr.it_mkLambda_or_LetIn c sign) where in
@@ -743,11 +741,11 @@ let detype_closed_glob ?lax isgoal avoid env sigma t =
| Name id -> Name (convert_id cl id)
| Anonymous -> Anonymous
in
- let rec detype_closed_glob cl = function
- | GVar (loc,id) ->
+ let rec detype_closed_glob cl cg : Glob_term.glob_constr = CAst.map (function
+ | GVar id ->
(* if [id] is bound to a name. *)
begin try
- GVar(loc,Id.Map.find id cl.idents)
+ GVar(Id.Map.find id cl.idents)
(* if [id] is bound to a typed term *)
with Not_found -> try
(* assumes [detype] does not raise [Not_found] exceptions *)
@@ -757,127 +755,128 @@ let detype_closed_glob ?lax isgoal avoid env sigma t =
[Printer.pr_constr_under_binders_env] does. *)
let assums = List.map (fun id -> LocalAssum (Name id,(* dummy *) mkProp)) b in
let env = push_rel_context assums env in
- detype ?lax isgoal avoid env sigma c
+ (detype ?lax isgoal avoid env sigma c).CAst.v
(* if [id] is bound to a [closed_glob_constr]. *)
with Not_found -> try
let {closure;term} = Id.Map.find id cl.untyped in
- detype_closed_glob closure term
+ (detype_closed_glob closure term).CAst.v
(* Otherwise [id] stands for itself *)
with Not_found ->
- GVar(loc,id)
+ GVar id
end
- | GLambda (loc,id,k,t,c) ->
+ | GLambda (id,k,t,c) ->
let id = convert_name cl id in
- GLambda(loc,id,k,detype_closed_glob cl t, detype_closed_glob cl c)
- | GProd (loc,id,k,t,c) ->
+ GLambda(id,k,detype_closed_glob cl t, detype_closed_glob cl c)
+ | GProd (id,k,t,c) ->
let id = convert_name cl id in
- GProd(loc,id,k,detype_closed_glob cl t, detype_closed_glob cl c)
- | GLetIn (loc,id,b,t,e) ->
+ GProd(id,k,detype_closed_glob cl t, detype_closed_glob cl c)
+ | GLetIn (id,b,t,e) ->
let id = convert_name cl id in
- GLetIn(loc,id,detype_closed_glob cl b, Option.map (detype_closed_glob cl) t, detype_closed_glob cl e)
- | GLetTuple (loc,ids,(n,r),b,e) ->
+ GLetIn(id,detype_closed_glob cl b, Option.map (detype_closed_glob cl) t, detype_closed_glob cl e)
+ | GLetTuple (ids,(n,r),b,e) ->
let ids = List.map (convert_name cl) ids in
let n = convert_name cl n in
- GLetTuple (loc,ids,(n,r),detype_closed_glob cl b, detype_closed_glob cl e)
- | GCases (loc,sty,po,tml,eqns) ->
+ GLetTuple (ids,(n,r),detype_closed_glob cl b, detype_closed_glob cl e)
+ | GCases (sty,po,tml,eqns) ->
let (tml,eqns) =
Glob_ops.map_pattern_binders (fun na -> convert_name cl na) tml eqns
in
let (tml,eqns) =
Glob_ops.map_pattern (fun c -> detype_closed_glob cl c) tml eqns
in
- GCases(loc,sty,po,tml,eqns)
+ GCases(sty,po,tml,eqns)
| c ->
- Glob_ops.map_glob_constr (detype_closed_glob cl) c
+ (Glob_ops.map_glob_constr (detype_closed_glob cl) cg).CAst.v
+ ) cg
in
detype_closed_glob t.closure t.term
(**********************************************************************)
(* Module substitution: relies on detyping *)
-let rec subst_cases_pattern subst pat =
- match pat with
- | PatVar _ -> pat
- | PatCstr (loc,((kn,i),j),cpl,n) ->
+let rec subst_cases_pattern subst = CAst.map (function
+ | PatVar _ as pat -> pat
+ | PatCstr (((kn,i),j),cpl,n) as pat ->
let kn' = subst_mind subst kn
and cpl' = List.smartmap (subst_cases_pattern subst) cpl in
if kn' == kn && cpl' == cpl then pat else
- PatCstr (loc,((kn',i),j),cpl',n)
+ PatCstr (((kn',i),j),cpl',n)
+ )
let (f_subst_genarg, subst_genarg_hook) = Hook.make ()
-let rec subst_glob_constr subst raw =
- match raw with
- | GRef (loc,ref,u) ->
+let rec subst_glob_constr subst = CAst.map (function
+ | GRef (ref,u) as raw ->
let ref',t = subst_global subst ref in
if ref' == ref then raw else
- detype false [] (Global.env()) Evd.empty (EConstr.of_constr t)
+ (detype false [] (Global.env()) Evd.empty (EConstr.of_constr t)).CAst.v
- | GVar _ -> raw
- | GEvar _ -> raw
- | GPatVar _ -> raw
+ | GSort _
+ | GVar _
+ | GEvar _
+ | GPatVar _ as raw -> raw
- | GApp (loc,r,rl) ->
+ | GApp (r,rl) as raw ->
let r' = subst_glob_constr subst r
and rl' = List.smartmap (subst_glob_constr subst) rl in
if r' == r && rl' == rl then raw else
- GApp(loc,r',rl')
+ GApp(r',rl')
- | GLambda (loc,n,bk,r1,r2) ->
+ | GLambda (n,bk,r1,r2) as raw ->
let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in
if r1' == r1 && r2' == r2 then raw else
- GLambda (loc,n,bk,r1',r2')
+ GLambda (n,bk,r1',r2')
- | GProd (loc,n,bk,r1,r2) ->
+ | GProd (n,bk,r1,r2) as raw ->
let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in
if r1' == r1 && r2' == r2 then raw else
- GProd (loc,n,bk,r1',r2')
+ GProd (n,bk,r1',r2')
- | GLetIn (loc,n,r1,t,r2) ->
+ | GLetIn (n,r1,t,r2) as raw ->
let r1' = subst_glob_constr subst r1 in
- let t' = Option.smartmap (subst_glob_constr subst) t in
let r2' = subst_glob_constr subst r2 in
+ let t' = Option.smartmap (subst_glob_constr subst) t in
if r1' == r1 && t == t' && r2' == r2 then raw else
- GLetIn (loc,n,r1',t',r2')
+ GLetIn (n,r1',t',r2')
- | GCases (loc,sty,rtno,rl,branches) ->
+ | GCases (sty,rtno,rl,branches) as raw ->
let rtno' = Option.smartmap (subst_glob_constr subst) rtno
and rl' = List.smartmap (fun (a,x as y) ->
let a' = subst_glob_constr subst a in
let (n,topt) = x in
let topt' = Option.smartmap
- (fun (loc,(sp,i),y as t) ->
+ (fun ((loc,((sp,i),y) as t)) ->
let sp' = subst_mind subst sp in
- if sp == sp' then t else (loc,(sp',i),y)) topt in
+ if sp == sp' then t else (loc,((sp',i),y))) topt in
if a == a' && topt == topt' then y else (a',(n,topt'))) rl
and branches' = List.smartmap
- (fun (loc,idl,cpl,r as branch) ->
+ (fun (loc,(idl,cpl,r) as branch) ->
let cpl' =
List.smartmap (subst_cases_pattern subst) cpl
and r' = subst_glob_constr subst r in
if cpl' == cpl && r' == r then branch else
- (loc,idl,cpl',r'))
+ (loc,(idl,cpl',r')))
branches
in
if rtno' == rtno && rl' == rl && branches' == branches then raw else
- GCases (loc,sty,rtno',rl',branches')
+ GCases (sty,rtno',rl',branches')
- | GLetTuple (loc,nal,(na,po),b,c) ->
+ | GLetTuple (nal,(na,po),b,c) as raw ->
let po' = Option.smartmap (subst_glob_constr subst) po
and b' = subst_glob_constr subst b
and c' = subst_glob_constr subst c in
if po' == po && b' == b && c' == c then raw else
- GLetTuple (loc,nal,(na,po'),b',c')
+ GLetTuple (nal,(na,po'),b',c')
- | GIf (loc,c,(na,po),b1,b2) ->
+ | GIf (c,(na,po),b1,b2) as raw ->
let po' = Option.smartmap (subst_glob_constr subst) po
and b1' = subst_glob_constr subst b1
and b2' = subst_glob_constr subst b2
and c' = subst_glob_constr subst c in
if c' == c && po' == po && b1' == b1 && b2' == b2 then raw else
- GIf (loc,c',(na,po'),b1',b2')
+ GIf (c',(na,po'),b1',b2')
- | GRec (loc,fix,ida,bl,ra1,ra2) ->
+ | GRec (fix,ida,bl,ra1,ra2) as raw ->
let ra1' = Array.smartmap (subst_glob_constr subst) ra1
and ra2' = Array.smartmap (subst_glob_constr subst) ra2 in
let bl' = Array.smartmap
@@ -887,11 +886,9 @@ let rec subst_glob_constr subst raw =
if ty'==ty && obd'==obd then dcl else (na,k,obd',ty')))
bl in
if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else
- GRec (loc,fix,ida,bl',ra1',ra2')
-
- | GSort _ -> raw
+ GRec (fix,ida,bl',ra1',ra2')
- | GHole (loc, knd, naming, solve) ->
+ | GHole (knd, naming, solve) as raw ->
let nknd = match knd with
| Evar_kinds.ImplicitArg (ref, i, b) ->
let nref, _ = subst_global subst ref in
@@ -900,25 +897,26 @@ let rec subst_glob_constr subst raw =
in
let nsolve = Option.smartmap (Hook.get f_subst_genarg subst) solve in
if nsolve == solve && nknd == knd then raw
- else GHole (loc, nknd, naming, nsolve)
+ else GHole (nknd, naming, nsolve)
- | GCast (loc,r1,k) ->
+ | GCast (r1,k) as raw ->
let r1' = subst_glob_constr subst r1 in
let k' = Miscops.smartmap_cast_type (subst_glob_constr subst) k in
- if r1' == r1 && k' == k then raw else GCast (loc,r1',k')
+ if r1' == r1 && k' == k then raw else GCast (r1',k')
+ )
(* Utilities to transform kernel cases to simple pattern-matching problem *)
let simple_cases_matrix_of_branches ind brs =
List.map (fun (i,n,b) ->
let nal,c = it_destRLambda_or_LetIn_names n b in
- let mkPatVar na = PatVar (Loc.ghost,na) in
- let p = PatCstr (Loc.ghost,(ind,i+1),List.map mkPatVar nal,Anonymous) in
+ let mkPatVar na = CAst.make @@ PatVar na in
+ let p = CAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in
let map name = try Some (Nameops.out_name name) with Failure _ -> None in
let ids = List.map_filter map nal in
- (Loc.ghost,ids,[p],c))
+ Loc.tag @@ (ids,[p],c))
brs
let return_type_of_predicate ind nrealargs_tags pred =
let nal,p = it_destRLambda_or_LetIn_names (nrealargs_tags@[false]) pred in
- (List.hd nal, Some (Loc.ghost, ind, List.tl nal)), Some p
+ (List.hd nal, Some (Loc.tag (ind, List.tl nal))), Some p
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index 4c6f9129f6..da287ae9f0 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -35,14 +35,6 @@ val detype_names : bool -> Id.t list -> names_context -> env -> evar_map -> cons
val detype : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> constr -> glob_constr
-val detype_case :
- bool -> (constr -> glob_constr) ->
- (constructor array -> bool list array -> constr array ->
- (Loc.t * Id.t list * cases_pattern list * glob_constr) list) ->
- (constr -> bool list -> bool) ->
- Id.t list -> inductive * case_style * bool list array * bool list ->
- constr option -> constr -> constr array -> glob_constr
-
val detype_sort : evar_map -> sorts -> glob_sort
val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) ->
@@ -54,7 +46,9 @@ val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> cl
val lookup_name_as_displayed : env -> evar_map -> constr -> Id.t -> int option
val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option
-val set_detype_anonymous : (Loc.t -> int -> glob_constr) -> unit
+(* XXX: This is a hack and should go away *)
+val set_detype_anonymous : (?loc:Loc.t -> int -> glob_constr) -> unit
+
val force_wildcard : unit -> bool
val synthetize_type : unit -> bool
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 305eae15a3..6fcbaa8ef5 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -887,7 +887,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
let test i = evar_conv_x trs env i CUMUL ty (substl ks b) in
(i,t2::ks, m-1, test)
else
- let dloc = (Loc.ghost,Evar_kinds.InternalHole) in
+ let dloc = Loc.tag Evar_kinds.InternalHole 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
@@ -1213,7 +1213,7 @@ let apply_conversion_problem_heuristic 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
+ ?loc:(loc_of_conv_pb evd pb) env
evd ?reason (t1, t2)
let check_problems_are_solved env evd =
@@ -1267,7 +1267,7 @@ let solve_unconstrained_impossible_cases env evd =
match ev_info.evar_source with
| loc,Evar_kinds.ImpossibleCase ->
let j, ctx = coq_unit_judge () in
- let evd' = Evd.merge_context_set Evd.univ_flexible_alg ~loc 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
diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml
index 5fd104c781..a116198465 100644
--- a/pretyping/evardefine.ml
+++ b/pretyping/evardefine.ml
@@ -180,7 +180,7 @@ let define_evar_as_sort env evd (ev,args) =
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 split_tycon ?loc env evd tycon =
let rec real_split evd c =
let t = Reductionops.whd_all env evd c in
match EConstr.kind evd t with
@@ -192,7 +192,7 @@ let split_tycon loc env evd tycon =
| App (c,args) when isEvar evd c ->
let (evd',lam) = define_evar_as_lambda env evd (destEvar evd c) in
real_split evd' (mkApp (lam,args))
- | _ -> error_not_product ~loc env evd c
+ | _ -> error_not_product ?loc env evd c
in
match tycon with
| None -> evd,(Anonymous,None,None)
diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli
index 2f7ac4efbe..b8134a28c5 100644
--- a/pretyping/evardefine.mli
+++ b/pretyping/evardefine.mli
@@ -31,7 +31,7 @@ val evar_absorb_arguments : env -> evar_map -> existential -> constr list ->
evar_map * existential
val split_tycon :
- Loc.t -> env -> evar_map -> type_constraint ->
+ ?loc:Loc.t -> env -> evar_map -> type_constraint ->
evar_map * (Name.t * type_constraint * type_constraint)
val valcon_of_tycon : type_constraint -> val_constraint
diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml
index 6509aaac3d..923d7d9388 100644
--- a/pretyping/glob_ops.ml
+++ b/pretyping/glob_ops.ml
@@ -15,19 +15,17 @@ open Glob_term
(* Untyped intermediate terms, after ASTs and before constr. *)
-let cases_pattern_loc = function
- PatVar(loc,_) -> loc
- | PatCstr(loc,_,_,_) -> loc
+let cases_pattern_loc c = c.CAst.loc
let cases_predicate_names tml =
List.flatten (List.map (function
| (tm,(na,None)) -> [na]
- | (tm,(na,Some (_,_,nal))) -> na::nal) tml)
+ | (tm,(na,Some (_,(_,nal)))) -> na::nal) tml)
-let mkGApp loc p t =
- match p with
- | GApp (loc,f,l) -> GApp (loc,f,l@[t])
- | _ -> GApp (loc,p,[t])
+let mkGApp ?loc p t = CAst.make ?loc @@
+ match p.CAst.v with
+ | GApp (f,l) -> GApp (f,l@[t])
+ | _ -> GApp (p,[t])
let map_glob_decl_left_to_right f (na,k,obd,ty) =
let comp1 = Option.map f obd in
@@ -47,9 +45,9 @@ let case_style_eq s1 s2 = match s1, s2 with
| RegularStyle, RegularStyle -> true
| _ -> false
-let rec cases_pattern_eq p1 p2 = match p1, p2 with
-| PatVar (_, na1), PatVar (_, na2) -> Name.equal na1 na2
-| PatCstr (_, c1, pl1, na1), PatCstr (_, c2, pl2, na2) ->
+let rec cases_pattern_eq { CAst.v = p1} { CAst.v = p2 } = match p1, p2 with
+| PatVar na1, PatVar na2 -> Name.equal na1 na2
+| PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) ->
eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 &&
Name.equal na1 na2
| _ -> false
@@ -61,57 +59,57 @@ let cast_type_eq eq t1 t2 = match t1, t2 with
| CastNative t1, CastNative t2 -> eq t1 t2
| _ -> false
-let rec glob_constr_eq c1 c2 = match c1, c2 with
-| GRef (_, gr1, _), GRef (_, gr2, _) -> eq_gr gr1 gr2
-| GVar (_, id1), GVar (_, id2) -> Id.equal id1 id2
-| GEvar (_, id1, arg1), GEvar (_, id2, arg2) ->
+let rec glob_constr_eq { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with
+| GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2
+| GVar id1, GVar id2 -> Id.equal id1 id2
+| GEvar (id1, arg1), GEvar (id2, arg2) ->
Id.equal id1 id2 &&
List.equal instance_eq arg1 arg2
-| GPatVar (_, (b1, pat1)), GPatVar (_, (b2, pat2)) ->
+| GPatVar (b1, pat1), GPatVar (b2, pat2) ->
(b1 : bool) == b2 && Id.equal pat1 pat2
-| GApp (_, f1, arg1), GApp (_, f2, arg2) ->
+| GApp (f1, arg1), GApp (f2, arg2) ->
glob_constr_eq f1 f2 && List.equal glob_constr_eq arg1 arg2
-| GLambda (_, na1, bk1, t1, c1), GLambda (_, na2, bk2, t2, c2) ->
+| GLambda (na1, bk1, t1, c1), GLambda (na2, bk2, t2, c2) ->
Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
glob_constr_eq t1 t2 && glob_constr_eq c1 c2
-| GProd (_, na1, bk1, t1, c1), GProd (_, na2, bk2, t2, c2) ->
+| GProd (na1, bk1, t1, c1), GProd (na2, bk2, t2, c2) ->
Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
glob_constr_eq t1 t2 && glob_constr_eq c1 c2
-| GLetIn (_, na1, b1, t1, c1), GLetIn (_, na2, b2, t2, c2) ->
+| GLetIn (na1, b1, t1, c1), GLetIn (na2, b2, t2, c2) ->
Name.equal na1 na2 && glob_constr_eq b1 b2 && Option.equal glob_constr_eq t1 t2 && glob_constr_eq c1 c2
-| GCases (_, st1, c1, tp1, cl1), GCases (_, st2, c2, tp2, cl2) ->
+| GCases (st1, c1, tp1, cl1), GCases (st2, c2, tp2, cl2) ->
case_style_eq st1 st2 && Option.equal glob_constr_eq c1 c2 &&
List.equal tomatch_tuple_eq tp1 tp2 &&
List.equal cases_clause_eq cl1 cl2
-| GLetTuple (_, na1, (n1, p1), c1, t1), GLetTuple (_, na2, (n2, p2), c2, t2) ->
+| GLetTuple (na1, (n1, p1), c1, t1), GLetTuple (na2, (n2, p2), c2, t2) ->
List.equal Name.equal na1 na2 && Name.equal n1 n2 &&
Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 &&
glob_constr_eq t1 t2
-| GIf (_, m1, (pat1, p1), c1, t1), GIf (_, m2, (pat2, p2), c2, t2) ->
+| GIf (m1, (pat1, p1), c1, t1), GIf (m2, (pat2, p2), c2, t2) ->
glob_constr_eq m1 m2 && Name.equal pat1 pat2 &&
Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 &&
glob_constr_eq t1 t2
-| GRec (_, kn1, id1, decl1, c1, t1), GRec (_, kn2, id2, decl2, c2, t2) ->
+| GRec (kn1, id1, decl1, c1, t1), GRec (kn2, id2, decl2, c2, t2) ->
fix_kind_eq kn1 kn2 && Array.equal Id.equal id1 id2 &&
Array.equal (fun l1 l2 -> List.equal glob_decl_eq l1 l2) decl1 decl2 &&
Array.equal glob_constr_eq c1 c2 &&
Array.equal glob_constr_eq t1 t2
-| GSort (_, s1), GSort (_, s2) -> Miscops.glob_sort_eq s1 s2
-| GHole (_, kn1, nam1, gn1), GHole (_, kn2, nam2, gn2) ->
+| GSort s1, GSort s2 -> Miscops.glob_sort_eq s1 s2
+| GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) ->
Option.equal (==) gn1 gn2 (** Only thing sensible *) &&
Miscops.intro_pattern_naming_eq nam1 nam2
-| GCast (_, c1, t1), GCast (_, c2, t2) ->
+| GCast (c1, t1), GCast (c2, t2) ->
glob_constr_eq c1 c2 && cast_type_eq glob_constr_eq t1 t2
| _ -> false
and tomatch_tuple_eq (c1, p1) (c2, p2) =
- let eqp (_, i1, na1) (_, i2, na2) =
+ let eqp (_, (i1, na1)) (_, (i2, na2)) =
eq_ind i1 i2 && List.equal Name.equal na1 na2
in
let eq_pred (n1, o1) (n2, o2) = Name.equal n1 n2 && Option.equal eqp o1 o2 in
glob_constr_eq c1 c2 && eq_pred p1 p2
-and cases_clause_eq (_, id1, p1, c1) (_, id2, p2, c2) =
+and cases_clause_eq (_, (id1, p1, c1)) (_, (id2, p2, c2)) =
List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 &&
glob_constr_eq c1 c2
@@ -139,105 +137,107 @@ and fix_recursion_order_eq o1 o2 = match o1, o2 with
and instance_eq (x1,c1) (x2,c2) =
Id.equal x1 x2 && glob_constr_eq c1 c2
-let map_glob_constr_left_to_right f = function
- | GApp (loc,g,args) ->
+let map_glob_constr_left_to_right f = CAst.map (function
+ | GApp (g,args) ->
let comp1 = f g in
let comp2 = Util.List.map_left f args in
- GApp (loc,comp1,comp2)
- | GLambda (loc,na,bk,ty,c) ->
+ GApp (comp1,comp2)
+ | GLambda (na,bk,ty,c) ->
let comp1 = f ty in
let comp2 = f c in
- GLambda (loc,na,bk,comp1,comp2)
- | GProd (loc,na,bk,ty,c) ->
+ GLambda (na,bk,comp1,comp2)
+ | GProd (na,bk,ty,c) ->
let comp1 = f ty in
let comp2 = f c in
- GProd (loc,na,bk,comp1,comp2)
- | GLetIn (loc,na,b,t,c) ->
+ GProd (na,bk,comp1,comp2)
+ | GLetIn (na,b,t,c) ->
let comp1 = f b in
let compt = Option.map f t in
let comp2 = f c in
- GLetIn (loc,na,comp1,compt,comp2)
- | GCases (loc,sty,rtntypopt,tml,pl) ->
+ GLetIn (na,comp1,compt,comp2)
+ | GCases (sty,rtntypopt,tml,pl) ->
let comp1 = Option.map f rtntypopt in
let comp2 = Util.List.map_left (fun (tm,x) -> (f tm,x)) tml in
- let comp3 = Util.List.map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in
- GCases (loc,sty,comp1,comp2,comp3)
- | GLetTuple (loc,nal,(na,po),b,c) ->
+ let comp3 = Util.List.map_left (fun (loc,(idl,p,c)) -> (loc,(idl,p,f c))) pl in
+ GCases (sty,comp1,comp2,comp3)
+ | GLetTuple (nal,(na,po),b,c) ->
let comp1 = Option.map f po in
let comp2 = f b in
let comp3 = f c in
- GLetTuple (loc,nal,(na,comp1),comp2,comp3)
- | GIf (loc,c,(na,po),b1,b2) ->
+ GLetTuple (nal,(na,comp1),comp2,comp3)
+ | GIf (c,(na,po),b1,b2) ->
let comp1 = Option.map f po in
let comp2 = f b1 in
let comp3 = f b2 in
- GIf (loc,f c,(na,comp1),comp2,comp3)
- | GRec (loc,fk,idl,bl,tyl,bv) ->
+ GIf (f c,(na,comp1),comp2,comp3)
+ | GRec (fk,idl,bl,tyl,bv) ->
let comp1 = Array.map (Util.List.map_left (map_glob_decl_left_to_right f)) bl in
let comp2 = Array.map f tyl in
let comp3 = Array.map f bv in
- GRec (loc,fk,idl,comp1,comp2,comp3)
- | GCast (loc,c,k) ->
+ GRec (fk,idl,comp1,comp2,comp3)
+ | GCast (c,k) ->
let comp1 = f c in
let comp2 = Miscops.map_cast_type f k in
- GCast (loc,comp1,comp2)
+ GCast (comp1,comp2)
| (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) as x -> x
+ )
let map_glob_constr = map_glob_constr_left_to_right
let fold_return_type f acc (na,tyopt) = Option.fold_left f acc tyopt
-let fold_glob_constr f acc = function
+let fold_glob_constr f acc = CAst.with_val (function
| GVar _ -> acc
- | GApp (_,c,args) -> List.fold_left f (f acc c) args
- | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) ->
+ | GApp (c,args) -> List.fold_left f (f acc c) args
+ | GLambda (_,_,b,c) | GProd (_,_,b,c) ->
f (f acc b) c
- | GLetIn (_,_,b,t,c) ->
+ | GLetIn (_,b,t,c) ->
f (Option.fold_left f (f acc b) t) c
- | GCases (_,_,rtntypopt,tml,pl) ->
- let fold_pattern acc (_,idl,p,c) = f acc c in
+ | GCases (_,rtntypopt,tml,pl) ->
+ let fold_pattern acc (_,(idl,p,c)) = f acc c in
List.fold_left fold_pattern
(List.fold_left f (Option.fold_left f acc rtntypopt) (List.map fst tml))
pl
- | GLetTuple (_,_,rtntyp,b,c) ->
+ | GLetTuple (_,rtntyp,b,c) ->
f (f (fold_return_type f acc rtntyp) b) c
- | GIf (_,c,rtntyp,b1,b2) ->
+ | GIf (c,rtntyp,b1,b2) ->
f (f (f (fold_return_type f acc rtntyp) c) b1) b2
- | GRec (_,_,_,bl,tyl,bv) ->
+ | GRec (_,_,bl,tyl,bv) ->
let acc = Array.fold_left
(List.fold_left (fun acc (na,k,bbd,bty) ->
f (Option.fold_left f acc bbd) bty)) acc bl in
Array.fold_left f (Array.fold_left f acc tyl) bv
- | GCast (_,c,k) ->
+ | GCast (c,k) ->
let acc = match k with
| CastConv t | CastVM t | CastNative t -> f acc t | CastCoerce -> acc in
f acc c
| (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc
+ )
let fold_return_type_with_binders f g v acc (na,tyopt) =
Option.fold_left (f (name_fold g na v)) acc tyopt
-let fold_glob_constr_with_binders g f v acc = function
+let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function
| GVar _ -> acc
- | GApp (_,c,args) -> List.fold_left (f v) (f v acc c) args
- | GLambda (_,na,_,b,c) | GProd (_,na,_,b,c) ->
+ | GApp (c,args) -> List.fold_left (f v) (f v acc c) args
+ | GLambda (na,_,b,c) | GProd (na,_,b,c) ->
f (name_fold g na v) (f v acc b) c
- | GLetIn (_,na,b,t,c) ->
+ | GLetIn (na,b,t,c) ->
f (name_fold g na v) (Option.fold_left (f v) (f v acc b) t) c
- | GCases (_,_,rtntypopt,tml,pl) ->
- let fold_pattern acc (_,idl,p,c) = f (List.fold_right g idl v) acc c in
+ | GCases (_,rtntypopt,tml,pl) ->
+ let fold_pattern acc (_,(idl,p,c)) = f (List.fold_right g idl v) acc c in
let fold_tomatch (v',acc) (tm,(na,onal)) =
- (Option.fold_left (fun v'' (_,_,nal) -> List.fold_right (name_fold g) nal v'')
+ (Option.fold_left (fun v'' (_,(_,nal)) -> List.fold_right (name_fold g) nal v'')
(name_fold g na v') onal,
f v acc tm) in
let (v',acc) = List.fold_left fold_tomatch (v,acc) tml in
let acc = Option.fold_left (f v') acc rtntypopt in
List.fold_left fold_pattern acc pl
- | GLetTuple (_,nal,rtntyp,b,c) ->
+ | GLetTuple (nal,rtntyp,b,c) ->
f v (f v (fold_return_type_with_binders f g v acc rtntyp) b) c
- | GIf (_,c,rtntyp,b1,b2) ->
+ | GIf (c,rtntyp,b1,b2) ->
f v (f v (f v (fold_return_type_with_binders f g v acc rtntyp) c) b1) b2
- | GRec (_,_,idl,bll,tyl,bv) ->
+ | GRec (_,idl,bll,tyl,bv) ->
let f' i acc fid =
let v,acc =
List.fold_left
@@ -247,17 +247,18 @@ let fold_glob_constr_with_binders g f v acc = function
bll.(i) in
f (Array.fold_right g idl v) (f v acc tyl.(i)) (bv.(i)) in
Array.fold_left_i f' acc idl
- | GCast (_,c,k) ->
+ | GCast (c,k) ->
let acc = match k with
| CastConv t | CastVM t | CastNative t -> f v acc t | CastCoerce -> acc in
f v acc c
- | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc
+ | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc))
let iter_glob_constr f = fold_glob_constr (fun () -> f) ()
let occur_glob_constr id =
+ let open CAst in
let rec occur barred acc = function
- | GVar (loc,id') -> Id.equal id id'
+ | { loc ; v = GVar id' } -> Id.equal id id'
| c ->
(* [g] looks if [id] appears in a binding position, in which
case, we don't have to look in the corresponding subterm *)
@@ -267,8 +268,9 @@ let occur_glob_constr id =
occur false false
let free_glob_vars =
+ let open CAst in
let rec vars bound vs = function
- | GVar (loc,id') -> if Id.Set.mem id' bound then vs else Id.Set.add id' vs
+ | { loc ; v = GVar id' } -> if Id.Set.mem id' bound then vs else Id.Set.add id' vs
| c -> fold_glob_constr_with_binders Id.Set.add vars bound vs c in
fun rt ->
let vs = vars Id.Set.empty Id.Set.empty rt in
@@ -276,7 +278,7 @@ let free_glob_vars =
let glob_visible_short_qualid c =
let rec aux acc = function
- | GRef (_,c,_) ->
+ | { CAst.v = 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
@@ -314,37 +316,38 @@ let bound_glob_vars =
probably be no significant penalty in doing reallocation as
pattern-matching expressions are usually rather small. *)
-let map_inpattern_binders f ((loc,id,nal) as x) =
+let map_inpattern_binders f ((loc,(id,nal)) as x) =
let r = CList.smartmap f nal in
if r == nal then x
- else loc,id,r
+ else loc,(id,r)
let map_tomatch_binders f ((c,(na,inp)) as x) : tomatch_tuple =
let r = Option.smartmap (fun p -> map_inpattern_binders f p) inp in
if r == inp then x
else c,(f na, r)
-let rec map_case_pattern_binders f = function
- | PatVar (loc,na) as x ->
+let rec map_case_pattern_binders f = CAst.map (function
+ | PatVar na as x ->
let r = f na in
if r == na then x
- else PatVar (loc,r)
- | PatCstr (loc,c,ps,na) as x ->
+ else PatVar r
+ | PatCstr (c,ps,na) as x ->
let rna = f na in
let rps =
CList.smartmap (fun p -> map_case_pattern_binders f p) ps
in
if rna == na && rps == ps then x
- else PatCstr(loc,c,rps,rna)
+ else PatCstr(c,rps,rna)
+ )
-let map_cases_branch_binders f ((loc,il,cll,rhs) as x) : cases_clause =
+let map_cases_branch_binders f ((loc,(il,cll,rhs)) as x) : cases_clause =
(* spiwack: not sure if I must do something with the list of idents.
It is intended to be a superset of the free variable of the
right-hand side, if I understand correctly. But I'm not sure when
or how they are used. *)
let r = List.smartmap (fun cl -> map_case_pattern_binders f cl) cll in
if r == cll then x
- else loc,il,r,rhs
+ else loc,(il,r,rhs)
let map_pattern_binders f tomatch branches =
CList.smartmap (fun tm -> map_tomatch_binders f tm) tomatch,
@@ -354,29 +357,14 @@ let map_pattern_binders f tomatch branches =
let map_tomatch f (c,pp) : tomatch_tuple = f c , pp
-let map_cases_branch f (loc,il,cll,rhs) : cases_clause =
- loc , il , cll , f rhs
+let map_cases_branch f (loc,(il,cll,rhs)) : cases_clause =
+ loc , (il , cll , f rhs)
let map_pattern f tomatch branches =
List.map (fun tm -> map_tomatch f tm) tomatch,
List.map (fun br -> map_cases_branch f br) branches
-let loc_of_glob_constr = function
- | GRef (loc,_,_) -> loc
- | GVar (loc,_) -> loc
- | GEvar (loc,_,_) -> loc
- | GPatVar (loc,_) -> loc
- | GApp (loc,_,_) -> loc
- | GLambda (loc,_,_,_,_) -> loc
- | GProd (loc,_,_,_,_) -> loc
- | GLetIn (loc,_,_,_,_) -> loc
- | GCases (loc,_,_,_,_) -> loc
- | GLetTuple (loc,_,_,_,_) -> loc
- | GIf (loc,_,_,_,_) -> loc
- | GRec (loc,_,_,_,_,_) -> loc
- | GSort (loc,_) -> loc
- | GHole (loc,_,_,_) -> loc
- | GCast (loc,_,_) -> loc
+let loc_of_glob_constr c = c.CAst.loc
(**********************************************************************)
(* Alpha-renaming *)
@@ -408,77 +396,78 @@ let rename_var l id =
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 rec rename_glob_vars l c = CAst.map_with_loc (fun ?loc -> function
+ | GVar 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 id == id' then r else GVar 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) ->
+ | GProd (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) ->
+ GProd (na,bk,rename_glob_vars l t,rename_glob_vars l' c)
+ | GLambda (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,t,c) ->
+ GLambda (na',bk,rename_glob_vars l t,rename_glob_vars l' c)
+ | GLetIn (na,b,t,c) ->
let na',l' = update_subst na l in
- GLetIn (loc,na',rename_glob_vars l b,Option.map (rename_glob_vars l) t,rename_glob_vars l' c)
+ GLetIn (na',rename_glob_vars l b,Option.map (rename_glob_vars l) t,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) ->
+ | GCases (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
+ 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) ->
+ 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 (ci,po,tomatchl,cls)
+ | GLetTuple (nal,(na,po),c,b) ->
List.iter (test_na l) (na::nal);
- GLetTuple (loc,nal,(na,Option.map (rename_glob_vars l) po),
+ GLetTuple (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) ->
+ | GIf (c,(na,po),b1,b2) ->
test_na l na;
- GIf (loc,rename_glob_vars l c,(na,Option.map (rename_glob_vars l) po),
+ GIf (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) ->
+ | GRec (k,idl,decls,bs,ts) ->
Array.iter (test_id l) idl;
- GRec (loc,k,idl,
+ GRec (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
+ | _ -> (map_glob_constr (rename_glob_vars l) c).CAst.v
+ ) c
(**********************************************************************)
(* Conversion from glob_constr to cases pattern, if possible *)
-let rec cases_pattern_of_glob_constr na = function
- | GVar (loc,id) ->
+let rec cases_pattern_of_glob_constr na = CAst.map (function
+ | GVar id ->
begin match na with
| Name _ ->
(* Unable to manage the presence of both an alias and a variable *)
raise Not_found
- | Anonymous -> PatVar (loc,Name id)
+ | Anonymous -> PatVar (Name id)
end
- | GHole (loc,_,_,_) -> PatVar (loc,na)
- | GRef (loc,ConstructRef cstr,_) ->
- PatCstr (loc,cstr,[],na)
- | GApp (loc,GRef (_,ConstructRef cstr,_),l) ->
- PatCstr (loc,cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na)
+ | GHole (_,_,_) -> PatVar na
+ | GRef (ConstructRef cstr,_) -> PatCstr (cstr,[],na)
+ | GApp ( { CAst.v = GRef (ConstructRef cstr,_) }, l) ->
+ PatCstr (cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na)
| _ -> raise Not_found
+ )
(* Turn a closed cases pattern into a glob_constr *)
-let rec glob_constr_of_closed_cases_pattern_aux = function
- | PatCstr (loc,cstr,[],Anonymous) ->
- GRef (loc,ConstructRef cstr,None)
- | PatCstr (loc,cstr,l,Anonymous) ->
- let ref = GRef (loc,ConstructRef cstr,None) in
- GApp (loc,ref, List.map glob_constr_of_closed_cases_pattern_aux l)
+let rec glob_constr_of_closed_cases_pattern_aux x = CAst.map_with_loc (fun ?loc -> function
+ | PatCstr (cstr,[],Anonymous) -> GRef (ConstructRef cstr,None)
+ | PatCstr (cstr,l,Anonymous) ->
+ let ref = CAst.make ?loc @@ GRef (ConstructRef cstr,None) in
+ GApp (ref, List.map glob_constr_of_closed_cases_pattern_aux l)
| _ -> raise Not_found
+ ) x
let glob_constr_of_closed_cases_pattern = function
- | PatCstr (loc,cstr,l,na) ->
- na,glob_constr_of_closed_cases_pattern_aux (PatCstr (loc,cstr,l,Anonymous))
+ | { CAst.loc ; v = PatCstr (cstr,l,na) } ->
+ na,glob_constr_of_closed_cases_pattern_aux (CAst.make ?loc @@ PatCstr (cstr,l,Anonymous))
| _ ->
raise Not_found
diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli
index af2834e498..aa48516aff 100644
--- a/pretyping/glob_ops.mli
+++ b/pretyping/glob_ops.mli
@@ -20,12 +20,12 @@ val glob_constr_eq : glob_constr -> glob_constr -> bool
(** Operations on [glob_constr] *)
-val cases_pattern_loc : cases_pattern -> Loc.t
+val cases_pattern_loc : cases_pattern -> Loc.t option
val cases_predicate_names : tomatch_tuples -> Name.t list
(** Apply one argument to a glob_constr *)
-val mkGApp : Loc.t -> glob_constr -> glob_constr -> glob_constr
+val mkGApp : ?loc:Loc.t -> glob_constr -> glob_constr -> glob_constr
val map_glob_constr :
(glob_constr -> glob_constr) -> glob_constr -> glob_constr
@@ -42,7 +42,8 @@ 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
+(* Obsolete *)
+val loc_of_glob_constr : glob_constr -> Loc.t option
val glob_visible_short_qualid : glob_constr -> Id.t list
(* Renaming free variables using a renaming map; fails with
diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml
index 1669f8334b..69bc2d11ff 100644
--- a/pretyping/miscops.ml
+++ b/pretyping/miscops.ml
@@ -62,7 +62,7 @@ let map_red_expr_gen f g h = function
(** Mapping bindings *)
let map_explicit_bindings f l =
- let map (loc, hyp, x) = (loc, hyp, f x) in
+ let map (loc, (hyp, x)) = (loc, (hyp, f x)) in
List.map map l
let map_bindings f = function
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index 638e12d7c1..a8012d35f8 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -14,7 +14,6 @@ open Nameops
open Term
open Vars
open Glob_term
-open Glob_ops
open Pp
open Mod_subst
open Misctypes
@@ -326,46 +325,46 @@ 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) ->
+let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function
+ | GVar id ->
(try PRel (List.index Name.equal (Name id) vars)
with Not_found -> PVar id)
- | GPatVar (_,(false,n)) ->
+ | GPatVar (false,n) ->
metas := n::!metas; PMeta (Some n)
- | GRef (_,gr,_) ->
+ | GRef (gr,_) ->
PRef (canonical_gr gr)
(* Hack to avoid rewriting a complete interpretation of patterns *)
- | GApp (_, GPatVar (_,(true,n)), cl) ->
+ | GApp ({ CAst.v = GPatVar (true,n) }, cl) ->
metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl)
- | GApp (_,c,cl) ->
+ | GApp (c,cl) ->
PApp (pat_of_raw metas vars c,
Array.of_list (List.map (pat_of_raw metas vars) cl))
- | GLambda (_,na,bk,c1,c2) ->
+ | GLambda (na,bk,c1,c2) ->
name_iter (fun n -> metas := n::!metas) na;
PLambda (na, pat_of_raw metas vars c1,
pat_of_raw metas (na::vars) c2)
- | GProd (_,na,bk,c1,c2) ->
+ | GProd (na,bk,c1,c2) ->
name_iter (fun n -> metas := n::!metas) na;
PProd (na, pat_of_raw metas vars c1,
pat_of_raw metas (na::vars) c2)
- | GLetIn (_,na,c1,t,c2) ->
+ | GLetIn (na,c1,t,c2) ->
name_iter (fun n -> metas := n::!metas) na;
PLetIn (na, pat_of_raw metas vars c1,
Option.map (pat_of_raw metas vars) t,
pat_of_raw metas (na::vars) c2)
- | GSort (_,s) ->
+ | GSort s ->
PSort s
| GHole _ ->
PMeta None
- | GCast (_,c,_) ->
+ | GCast (c,_) ->
warn_cast_in_pattern ();
pat_of_raw metas vars c
- | GIf (_,c,(_,None),b1,b2) ->
+ | GIf (c,(_,None),b1,b2) ->
PIf (pat_of_raw metas vars c,
pat_of_raw metas vars b1,pat_of_raw metas vars b2)
- | GLetTuple (loc,nal,(_,None),b,c) ->
- let mkGLambda c na =
- GLambda (loc,na,Explicit,GHole (loc,Evar_kinds.InternalHole, IntroAnonymous, None),c) in
+ | GLetTuple (nal,(_,None),b,c) ->
+ let mkGLambda c na = CAst.make ?loc @@
+ GLambda (na,Explicit, CAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None),c) in
let c = List.fold_left mkGLambda c nal in
let cip =
{ cip_style = LetStyle;
@@ -376,24 +375,24 @@ let rec pat_of_raw metas vars = function
let tags = List.map (fun _ -> false) nal (* Approximation which can be without let-ins... *) in
PCase (cip, PMeta None, pat_of_raw metas vars b,
[0,tags,pat_of_raw metas vars c])
- | GCases (loc,sty,p,[c,(na,indnames)],brs) ->
+ | GCases (sty,p,[c,(na,indnames)],brs) ->
let get_ind = function
- | (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind
+ | (_,(_,[{ CAst.v = PatCstr((ind,_),_,_) }],_))::_ -> Some ind
| _ -> None
in
let ind_tags,ind = match indnames with
- | Some (_,ind,nal) -> Some (List.length nal), Some ind
+ | Some (_,(ind,nal)) -> Some (List.length nal), Some ind
| None -> None, get_ind brs
in
let ext,brs = pats_of_glob_branches loc metas vars ind brs
in
let pred = match p,indnames with
- | Some p, Some (_,_,nal) ->
+ | Some p, Some (_,(_,nal)) ->
let nvars = na :: List.rev nal @ vars in
rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p))
- | (None | Some (GHole _)), _ -> PMeta None
+ | (None | Some { CAst.v = GHole _}), _ -> PMeta None
| Some p, None ->
- user_err ~loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.")
+ user_err ?loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.")
in
let info =
{ cip_style = sty;
@@ -406,26 +405,27 @@ let rec pat_of_raw metas vars = function
one non-trivial branch. These facts are used in [Constrextern]. *)
PCase (info, pred, pat_of_raw metas vars c, brs)
- | r -> err ~loc:(loc_of_glob_constr r) (Pp.str "Non supported pattern.")
+ | r -> err ?loc (Pp.str "Non supported pattern.")
+ )
and pats_of_glob_branches loc metas vars ind brs =
let get_arg = function
- | PatVar(_,na) ->
+ | { CAst.v = PatVar na } ->
name_iter (fun n -> metas := n::!metas) na;
na
- | PatCstr(loc,_,_,_) -> err ~loc (Pp.str "Non supported pattern.")
+ | { CAst.v = PatCstr(_,_,_) ; loc } -> err ?loc (Pp.str "Non supported pattern.")
in
let rec get_pat indexes = function
| [] -> false, []
- | [(_,_,[PatVar(_,Anonymous)],GHole _)] -> true, [] (* ends with _ => _ *)
- | (_,_,[PatCstr(_,(indsp,j),lv,_)],br) :: brs ->
+ | [(_,(_,[{ CAst.v = PatVar Anonymous }], { CAst.v = GHole _}))] -> true, [] (* ends with _ => _ *)
+ | (_,(_,[{ CAst.v = PatCstr((indsp,j),lv,_) }],br)) :: brs ->
let () = match ind with
| Some sp when eq_ind sp indsp -> ()
| _ ->
- err ~loc (Pp.str "All constructors must be in the same inductive type.")
+ err ?loc (Pp.str "All constructors must be in the same inductive type.")
in
if Int.Set.mem (j-1) indexes then
- err ~loc
+ err ?loc
(str "No unique branch for " ++ int j ++ str"-th constructor.");
let lna = List.map get_arg lv in
let vars' = List.rev lna @ vars in
@@ -433,7 +433,7 @@ and pats_of_glob_branches loc metas vars ind brs =
let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in
let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in
ext, ((j-1, tags, pat) :: pats)
- | (loc,_,_,_) :: _ -> err ~loc (Pp.str "Non supported pattern.")
+ | (loc,(_,_,_)) :: _ -> err ?loc (Pp.str "Non supported pattern.")
in
get_pat Int.Set.empty brs
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index f9cf6b83bc..d7c04b08b0 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -176,7 +176,7 @@ let unsatisfiable_constraints env evd ev comp =
| Some ev ->
let loc, kind = Evd.evar_source ev evd in
let err = UnsatisfiableConstraints (Some (ev, kind), comp) in
- Loc.raise ~loc (PretypeError (env,evd,err))
+ Loc.raise ?loc (PretypeError (env,evd,err))
let unsatisfiable_exception exn =
match exn with
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 4886423bd0..53df5aa4a5 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -132,7 +132,7 @@ let nf_fix sigma (nas, cs, ts) =
let inj c = EConstr.to_constr sigma c in
(nas, Array.map inj cs, Array.map inj ts)
-let search_guard loc env possible_indexes fixdefs =
+let search_guard ?loc env possible_indexes fixdefs =
(* Standard situation with only one possibility for each fix. *)
(* We treat it separately in order to get proper error msg. *)
let is_singleton = function [_] -> true | _ -> false in
@@ -142,7 +142,7 @@ let search_guard loc env possible_indexes fixdefs =
(try check_fix env fix
with reraise ->
let (e, info) = CErrors.push reraise in
- let info = Loc.add_loc info loc in
+ let info = Option.cata (fun loc -> Loc.add_loc info loc) info loc in
iraise (e, info));
indexes
else
@@ -165,7 +165,7 @@ let search_guard loc env possible_indexes fixdefs =
with TypeError _ -> ())
(List.combinations possible_indexes);
let errmsg = "Cannot guess decreasing argument of fix." in
- user_err ~loc ~hdr:"search_guard" (Pp.str errmsg)
+ user_err ?loc ~hdr:"search_guard" (Pp.str errmsg)
with Found indexes -> indexes)
(* To force universe name declaration before use *)
@@ -190,12 +190,12 @@ let _ =
optkey = ["Universe";"Minimization";"ToSet"];
optread = Universes.is_set_minimization;
optwrite = (:=) Universes.set_minimization })
-
+
(** Miscellaneous interpretation functions *)
-let interp_universe_level_name ~anon_rigidity evd (loc,s) =
+let interp_universe_level_name ~anon_rigidity evd (loc, s) =
match s with
| Anonymous ->
- new_univ_level_variable ~loc anon_rigidity evd
+ new_univ_level_variable ?loc anon_rigidity evd
| Name s ->
let s = Id.to_string s in
let names, _ = Global.global_universe_names () in
@@ -220,8 +220,8 @@ let interp_universe_level_name ~anon_rigidity evd (loc,s) =
evd, snd (Idmap.find id names)
with Not_found ->
if not (is_strict_universe_declarations ()) then
- new_univ_level_variable ~loc ~name:s univ_rigid evd
- else user_err ~loc ~hdr:"interp_universe_level_name"
+ new_univ_level_variable ?loc ~name:s univ_rigid evd
+ else user_err ?loc ~hdr:"interp_universe_level_name"
(Pp.(str "Undeclared universe: " ++ str s))
let interp_universe ?loc evd = function
@@ -234,9 +234,9 @@ let interp_universe ?loc evd = function
(evd', Univ.sup u (Univ.Universe.make l)))
(evd, Univ.Universe.type0m) l
-let interp_level_info loc evd : Misctypes.level_info -> _ = function
- | None -> new_univ_level_variable ~loc univ_rigid evd
- | Some (loc,s) -> interp_universe_level_name ~anon_rigidity:univ_flexible evd (loc,s)
+let interp_level_info ?loc evd : Misctypes.level_info -> _ = function
+ | None -> new_univ_level_variable ?loc univ_rigid evd
+ | Some (loc,s) -> interp_universe_level_name ~anon_rigidity:univ_flexible evd (Loc.tag ?loc s)
let interp_sort ?loc evd = function
| GProp -> evd, Prop Null
@@ -342,7 +342,7 @@ let check_extra_evars_are_solved env current_sigma frozen = match frozen with
match k with
| Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
| _ ->
- error_unsolvable_implicit ~loc env current_sigma evk None) pending
+ error_unsolvable_implicit ?loc env current_sigma evk None) pending
(* [check_evars] fails if some unresolved evar remains *)
@@ -354,7 +354,7 @@ let check_evars env initial_sigma sigma c =
let (loc,k) = evar_source evk sigma in
begin match k with
| Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
- | _ -> Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None
+ | _ -> Pretype_errors.error_unsolvable_implicit ?loc env sigma evk None
end
| _ -> EConstr.iter sigma proc_rec c
in proc_rec c
@@ -389,18 +389,18 @@ let process_inference_flags flags env initial_sigma (sigma,c) =
let allow_anonymous_refs = ref false
(* coerce to tycon if any *)
-let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function
+let inh_conv_coerce_to_tycon ?loc resolve_tc env evdref j = function
| None -> j
| Some t ->
- evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env.ExtraEnv.env) evdref j t
+ evd_comb2 (Coercion.inh_conv_coerce_to ?loc resolve_tc env.ExtraEnv.env) evdref j t
let check_instance loc subst = function
| [] -> ()
| (id,_) :: _ ->
if List.mem_assoc id subst then
- user_err ~loc (pr_id id ++ str "appears more than once.")
+ user_err ?loc (pr_id id ++ str "appears more than once.")
else
- user_err ~loc (str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".")
+ user_err ?loc (str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".")
(* used to enforce a name in Lambda when the type constraints itself
is named, hence possibly dependent *)
@@ -480,7 +480,7 @@ let pretype_id pretype k0 loc env evdref lvar id =
(* and build a nice error message *)
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
+ user_err ?loc
(str "Variable " ++ pr_id id ++ str " should be bound to a term but is \
bound to a " ++ Geninterp.Val.pr typ ++ str ".")
end;
@@ -489,47 +489,47 @@ let pretype_id pretype k0 loc env evdref lvar id =
{ uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id env) }
with Not_found ->
(* [id] not found, standard error message *)
- error_var_not_found ~loc id
+ error_var_not_found ?loc id
(*************************************************************************)
(* Main pretyping function *)
-let interp_glob_level loc evd : Misctypes.glob_level -> _ = function
+let interp_glob_level ?loc evd : Misctypes.glob_level -> _ = function
| GProp -> evd, Univ.Level.prop
| GSet -> evd, Univ.Level.set
- | GType s -> interp_level_info loc evd s
+ | GType s -> interp_level_info ?loc evd s
-let interp_instance loc evd ~len l =
+let interp_instance ?loc evd ~len l =
if len != List.length l then
- user_err ~loc ~hdr:"pretype"
+ user_err ?loc ~hdr:"pretype"
(str "Universe instance should have length " ++ int len)
else
let evd, l' =
List.fold_left
(fun (evd, univs) l ->
- let evd, l = interp_glob_level loc evd l in
+ let evd, l = interp_glob_level ?loc evd l in
(evd, l :: univs)) (evd, [])
l
in
if List.exists (fun l -> Univ.Level.is_prop l) l' then
- user_err ~loc ~hdr:"pretype"
+ user_err ?loc ~hdr:"pretype"
(str "Universe instances cannot contain Prop, polymorphic" ++
str " universe instances must be greater or equal to Set.");
evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l')))
-let pretype_global loc rigid env evd gr us =
+let pretype_global ?loc rigid env evd gr us =
let evd, instance =
match us with
| None -> evd, None
| Some l ->
let _, ctx = Universes.unsafe_constr_of_global gr in
let len = Univ.UContext.size ctx in
- interp_instance loc evd ~len l
+ interp_instance ?loc evd ~len l
in
- let (sigma, c) = Evd.fresh_global ~loc ~rigid ?names:instance env.ExtraEnv.env evd gr in
+ let (sigma, c) = Evd.fresh_global ?loc ~rigid ?names:instance env.ExtraEnv.env evd gr in
(sigma, EConstr.of_constr c)
-let pretype_ref loc evdref env ref us =
+let pretype_ref ?loc evdref env ref us =
match ref with
| VarRef id ->
(* Section variable *)
@@ -538,24 +538,24 @@ let pretype_ref loc evdref env ref us =
(* This may happen if env is a goal env and section variables have
been cleared - section variables should be different from goal
variables *)
- Pretype_errors.error_var_not_found ~loc id)
+ Pretype_errors.error_var_not_found ?loc id)
| ref ->
- let evd, c = pretype_global loc univ_flexible env !evdref ref us in
+ let evd, c = pretype_global ?loc univ_flexible env !evdref ref us in
let () = evdref := evd in
let ty = unsafe_type_of env.ExtraEnv.env evd c in
make_judge c ty
-let judge_of_Type loc evd s =
- let evd, s = interp_universe ~loc 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 loc evdref = function
+let pretype_sort ?loc evdref = function
| GProp -> judge_of_prop
| GSet -> judge_of_set
- | GType s -> evd_comb1 (judge_of_Type loc) evdref s
+ | GType s -> evd_comb1 (judge_of_Type ?loc) evdref s
let new_type_evar env evdref loc =
let sigma = Sigma.Unsafe.of_evar_map !evdref in
@@ -573,35 +573,36 @@ let (f_genarg_interp, genarg_interp_hook) = Hook.make ()
(* the type constraint tycon *)
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 inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc 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
- (pretype_ref loc evdref env ref u)
+ let loc = t.CAst.loc in
+ match t.CAst.v with
+ | GRef (ref,u) ->
+ inh_conv_coerce_to_tycon ?loc env evdref
+ (pretype_ref ?loc evdref env ref u)
tycon
- | GVar (loc, id) ->
- inh_conv_coerce_to_tycon loc env evdref
+ | GVar id ->
+ inh_conv_coerce_to_tycon ?loc env evdref
(pretype_id (fun e r l t -> pretype tycon e r l t) k0 loc env evdref lvar id)
tycon
- | GEvar (loc, id, inst) ->
+ | GEvar (id, inst) ->
(* Ne faudrait-il pas s'assurer que hyps est bien un
sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
let evk =
try Evd.evar_key id !evdref
with Not_found ->
- user_err ~loc (str "Unknown existential variable.") in
+ user_err ?loc (str "Unknown existential variable.") in
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.ExtraEnv.env !evdref c) in
- inh_conv_coerce_to_tycon loc env evdref j tycon
+ inh_conv_coerce_to_tycon ?loc env evdref j tycon
- | GPatVar (loc,(someta,n)) ->
+ | GPatVar (someta,n) ->
let env = ltac_interp_name_env k0 lvar env !evdref in
let ty =
match tycon with
@@ -610,7 +611,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
let k = Evar_kinds.MatchingVar (someta,n) in
{ uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty }
- | GHole (loc, k, naming, None) ->
+ | GHole (k, naming, None) ->
let env = ltac_interp_name_env k0 lvar env !evdref in
let ty =
match tycon with
@@ -619,7 +620,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
new_type_evar env evdref loc in
{ uj_val = e_new_evar env evdref ~src:(loc,k) ~naming ty; uj_type = ty }
- | GHole (loc, k, _naming, Some arg) ->
+ | GHole (k, _naming, Some arg) ->
let env = ltac_interp_name_env k0 lvar env !evdref in
let ty =
match tycon with
@@ -631,7 +632,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
let () = evdref := sigma in
{ uj_val = c; uj_type = ty }
- | GRec (loc,fixkind,names,bl,lar,vdef) ->
+ | GRec (fixkind,names,bl,lar,vdef) ->
let rec type_bl env ctxt = function
[] -> ctxt
| (na,bk,None,ty)::bl ->
@@ -679,7 +680,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
{ uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
ctxtv vdef in
- Typing.check_type_fixpoint loc env.ExtraEnv.env evdref names ftys vdefj;
+ Typing.check_type_fixpoint ?loc env.ExtraEnv.env evdref names ftys vdefj;
let nf c = nf_evar !evdref c in
let ftys = Array.map nf ftys in (** FIXME *)
let fdefs = Array.map (fun x -> nf (j_val x)) vdefj in
@@ -701,7 +702,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
let fixdecls = (names,ftys,fdefs) in
let indexes =
search_guard
- loc env.ExtraEnv.env possible_indexes (nf_fix !evdref fixdecls)
+ ?loc env.ExtraEnv.env possible_indexes (nf_fix !evdref fixdecls)
in
make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
| GCoFix i ->
@@ -710,17 +711,17 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
(try check_cofix env.ExtraEnv.env (i, nf_fix !evdref fixdecls)
with reraise ->
let (e, info) = CErrors.push reraise in
- let info = Loc.add_loc info loc in
+ let info = Option.cata (Loc.add_loc info) info loc in
iraise (e, info));
make_judge (mkCoFix cofix) ftys.(i)
in
- inh_conv_coerce_to_tycon loc env evdref fixj tycon
+ inh_conv_coerce_to_tycon ?loc env evdref fixj tycon
- | GSort (loc,s) ->
- let j = pretype_sort loc evdref s in
- inh_conv_coerce_to_tycon loc env evdref j tycon
+ | GSort s ->
+ let j = pretype_sort ?loc evdref s in
+ inh_conv_coerce_to_tycon ?loc env evdref j tycon
- | GApp (loc,f,args) ->
+ | GApp (f,args) ->
let fj = pretype empty_tycon env evdref lvar f in
let floc = loc_of_glob_constr f in
let length = List.length args in
@@ -780,7 +781,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
| _ ->
let hj = pretype empty_tycon env evdref lvar c in
error_cant_apply_not_functional
- ~loc:(Loc.merge floc argloc) env.ExtraEnv.env !evdref
+ ?loc:(Loc.merge_opt floc argloc) env.ExtraEnv.env !evdref
resj [|hj|]
in
let resj = apply_rec env 1 fj candargs args in
@@ -797,19 +798,19 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
else resj
| _ -> resj
in
- inh_conv_coerce_to_tycon loc env evdref resj tycon
+ inh_conv_coerce_to_tycon ?loc env evdref resj tycon
- | GLambda(loc,name,bk,c1,c2) ->
+ | GLambda(name,bk,c1,c2) ->
let tycon' = evd_comb1
(fun evd tycon ->
match tycon with
| None -> evd, tycon
| Some ty ->
- let evd, ty' = Coercion.inh_coerce_to_prod loc env.ExtraEnv.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.ExtraEnv.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
@@ -819,9 +820,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
let j' = pretype rng (push_rel !evdref var env) evdref lvar c2 in
let name = ltac_interp_name lvar name 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
+ inh_conv_coerce_to_tycon ?loc env evdref resj tycon
- | GProd(loc,name,bk,c1,c2) ->
+ | GProd(name,bk,c1,c2) ->
let j = pretype_type empty_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
@@ -841,11 +842,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
judge_of_product env.ExtraEnv.env name j j'
with TypeError _ as e ->
let (e, info) = CErrors.push e in
- let info = Loc.add_loc info loc in
+ let info = Option.cata (Loc.add_loc info) info loc in
iraise (e, info) in
- inh_conv_coerce_to_tycon loc env evdref resj tycon
+ inh_conv_coerce_to_tycon ?loc env evdref resj tycon
- | GLetIn(loc,name,c1,t,c2) ->
+ | GLetIn(name,c1,t,c2) ->
let tycon1 =
match t with
| Some t ->
@@ -866,21 +867,21 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
{ uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
uj_type = subst1 j.uj_val j'.uj_type }
- | GLetTuple (loc,nal,(na,po),c,d) ->
+ | GLetTuple (nal,(na,po),c,d) ->
let cj = pretype empty_tycon env evdref lvar c in
let (IndType (indf,realargs)) =
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.ExtraEnv.env !evdref cj
+ 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) 1) then
- user_err ~loc (str "Destructing let is only for inductive types" ++
+ user_err ?loc (str "Destructing let is only for inductive types" ++
str " with one constructor.");
let cs = cstrs.(0) in
if not (Int.equal (List.length nal) cs.cs_nargs) then
- user_err ~loc:loc (str "Destructing let on this type expects " ++
+ user_err ?loc:loc (str "Destructing let on this type expects " ++
int cs.cs_nargs ++ str " variables.");
let fsign, record =
let set_name na d = set_name na (map_rel_decl EConstr.of_constr d) in
@@ -949,7 +950,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
if noccur_between !evdref 1 cs.cs_nargs ccl then
lift (- cs.cs_nargs) ccl
else
- error_cant_find_case_type ~loc env.ExtraEnv.env !evdref
+ error_cant_find_case_type ?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
@@ -959,16 +960,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
obj ind p cj.uj_val fj.uj_val
in { uj_val = v; uj_type = ccl })
- | GIf (loc,c,(na,po),b1,b2) ->
+ | GIf (c,(na,po),b1,b2) ->
let cj = pretype empty_tycon env evdref lvar c in
let (IndType (indf,realargs)) =
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.ExtraEnv.env !evdref cj 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
+ user_err ?loc
(str "If is only for inductive types with two constructors.");
let arsgn =
@@ -1025,19 +1026,19 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
mkCase (ci, pred, cj.uj_val, [|b1;b2|])
in
let cj = { uj_val = v; uj_type = p } in
- inh_conv_coerce_to_tycon loc env evdref cj tycon
+ inh_conv_coerce_to_tycon ?loc env evdref cj tycon
- | GCases (loc,sty,po,tml,eqns) ->
- Cases.compile_cases loc sty
+ | GCases (sty,po,tml,eqns) ->
+ Cases.compile_cases ?loc sty
((fun vtyc env evdref -> pretype vtyc (make_env env !evdref) evdref lvar),evdref)
tycon env.ExtraEnv.env (* loc *) (po,tml,eqns)
- | GCast (loc,c,k) ->
+ | GCast (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.ExtraEnv.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
@@ -1053,9 +1054,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
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 env.ExtraEnv.env !evdref cj tval
+ error_actual_type ?loc env.ExtraEnv.env !evdref cj tval
(ConversionFailed (env.ExtraEnv.env,cty,tval))
- else user_err ~loc (str "Cannot check cast with vm: " ++
+ else user_err ?loc (str "Cannot check cast with vm: " ++
str "unresolved arguments remain.")
| NATIVEcast ->
let cj = pretype empty_tycon env evdref lvar c in
@@ -1064,7 +1065,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
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 env.ExtraEnv.env !evdref cj tval
+ error_actual_type ?loc env.ExtraEnv.env !evdref cj tval
(ConversionFailed (env.ExtraEnv.env,cty,tval))
end
| _ ->
@@ -1072,7 +1073,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
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
+ 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 decl (subst,update) =
@@ -1092,7 +1093,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
let t' = env |> lookup_named id |> NamedDecl.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 (str "Cannot interpret " ++
+ user_err ?loc (str "Cannot interpret " ++
pr_existential_key !evdref evk ++
str " in current context: no binding for " ++ pr_id id ++ str ".") in
((id,c)::subst, update) in
@@ -1102,7 +1103,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update =
(* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function
- | GHole (loc, knd, naming, None) ->
+ | { loc; CAst.v = GHole (knd, naming, None) } ->
let rec is_Type c = match EConstr.kind !evdref c with
| Sort s ->
begin match ESorts.kind !evdref s with
@@ -1133,14 +1134,14 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) 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.ExtraEnv.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.ExtraEnv.env evdref v tj.utj_val then tj
else
error_unexpected_type
- ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v
+ ?loc:(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 sigma in
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index f13c10b055..79fafcf1a4 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -24,7 +24,7 @@ open Misctypes
(** An auxiliary function for searching for fixpoint guard indexes *)
val search_guard :
- Loc.t -> env -> int list list -> rec_declaration -> int array
+ ?loc:Loc.t -> env -> int list list -> rec_declaration -> int array
type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index 00535adb7d..757e12451e 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -152,13 +152,13 @@ let e_judge_of_case env evdref ci pj cj lfj =
{ 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 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
- error_ill_typed_rec_body ~loc env !evdref
+ error_ill_typed_rec_body ?loc env !evdref
i lna vdefj lar
done
@@ -360,7 +360,7 @@ 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 _ = check_type_fixpoint Loc.ghost env1 evdref names lara vdefj in
+ let _ = check_type_fixpoint env1 evdref names lara vdefj in
(names,lara,vdefv)
and execute_array env evdref = Array.map (execute env evdref)
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index 91134b4999..1f3ba34e51 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -44,7 +44,7 @@ val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr ->
(** Raise an error message if bodies have types not unifiable with the
expected ones *)
-val check_type_fixpoint : Loc.t -> env -> evar_map ref ->
+val check_type_fixpoint : ?loc:Loc.t -> env -> evar_map ref ->
Names.Name.t array -> types array -> unsafe_judgment array -> unit
val judge_of_prop : unsafe_judgment
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 661c1d8657..74fbd2a851 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1250,7 +1250,7 @@ let applyHead env (type r) (evd : r Sigma.t) n c =
let sigma = Sigma.to_evar_map evd in
match EConstr.kind sigma (whd_all env sigma cty) with
| Prod (_,c1,c2) ->
- let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
+ let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 in
apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd'
| _ -> error "Apply_Head_Then"
in
@@ -1265,7 +1265,7 @@ let is_mimick_head sigma ts f =
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',j') = inh_conv_coerce_rigid_to true env evd j tycon in
let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in
let evd' = Evd.map_metas_fvalue (fun c -> EConstr.Unsafe.to_constr (nf_evar evd' (EConstr.of_constr c))) evd' in
(evd',j'.uj_val)
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-05 09:38:29 +0000