aboutsummaryrefslogtreecommitdiff
path: root/vernac
diff options
context:
space:
mode:
Diffstat (limited to 'vernac')
-rw-r--r--vernac/auto_ind_decl.ml31
-rw-r--r--vernac/class.ml3
-rw-r--r--vernac/classes.ml24
-rw-r--r--vernac/classes.mli4
-rw-r--r--vernac/command.ml103
-rw-r--r--vernac/command.mli20
-rw-r--r--vernac/discharge.ml122
-rw-r--r--vernac/himsg.ml31
-rw-r--r--vernac/indschemes.ml14
-rw-r--r--vernac/indschemes.mli3
-rw-r--r--vernac/lemmas.ml95
-rw-r--r--vernac/lemmas.mli8
-rw-r--r--vernac/metasyntax.ml459
-rw-r--r--vernac/metasyntax.mli11
-rw-r--r--vernac/mltop.ml4
-rw-r--r--vernac/obligations.ml29
-rw-r--r--vernac/obligations.mli4
-rw-r--r--vernac/proof_using.ml190
-rw-r--r--vernac/proof_using.mli (renamed from vernac/discharge.mli)17
-rw-r--r--vernac/record.ml12
-rw-r--r--vernac/record.mli2
-rw-r--r--vernac/topfmt.ml5
-rw-r--r--vernac/vernac.mllib1
-rw-r--r--vernac/vernacentries.ml154
-rw-r--r--vernac/vernacentries.mli16
-rw-r--r--vernac/vernacinterp.ml14
-rw-r--r--vernac/vernacinterp.mli4
-rw-r--r--vernac/vernacprop.ml3
28 files changed, 750 insertions, 633 deletions
diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml
index 59920742d8..66a4a2e492 100644
--- a/vernac/auto_ind_decl.ml
+++ b/vernac/auto_ind_decl.ml
@@ -91,6 +91,15 @@ let destruct_on_using c id =
let destruct_on_as c l =
destruct false None c (Some (Loc.tag l)) None
+let inj_flags = Some {
+ Equality.keep_proof_equalities = true; (* necessary *)
+ injection_in_context = true; (* does not matter here *)
+ Equality.injection_pattern_l2r_order = true; (* does not matter here *)
+ }
+
+let my_discr_tac = Equality.discr_tac false None
+let my_inj_tac x = Equality.inj inj_flags None false None (EConstr.mkVar x,NoBindings)
+
(* reconstruct the inductive with the correct de Bruijn indexes *)
let mkFullInd (ind,u) n =
let mib = Global.lookup_mind (fst ind) in
@@ -181,7 +190,7 @@ let build_beq_scheme mode kn =
match EConstr.kind sigma c with
| Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants
| Var x ->
- let eid = id_of_string ("eq_"^(string_of_id x)) in
+ let eid = Id.of_string ("eq_"^(Id.to_string x)) in
let () =
try ignore (Environ.lookup_named eid env)
with Not_found -> raise (ParameterWithoutEquality (VarRef x))
@@ -533,7 +542,7 @@ open Namegen
let compute_bl_goal ind lnamesparrec nparrec =
let eqI, eff = eqI ind lnamesparrec in
let list_id = list_id lnamesparrec in
- let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in
+ let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in
let create_input c =
let x = next_ident_away (Id.of_string "x") avoid and
y = next_ident_away (Id.of_string "y") avoid in
@@ -578,7 +587,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec =
( List.map (fun (_,_,sbl,_ ) -> sbl) list_id )
in
let fresh_id s gl =
- let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in
+ let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in
avoid := fresh::(!avoid); fresh
in
Proofview.Goal.enter begin fun gl ->
@@ -595,7 +604,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec =
intro_using freshz;
intros;
Tacticals.New.tclTRY (
- Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None)
+ Tacticals.New.tclORELSE reflexivity my_discr_tac
);
simpl_in_hyp (freshz,Locus.InHyp);
(*
@@ -676,7 +685,7 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind
let compute_lb_goal ind lnamesparrec nparrec =
let list_id = list_id lnamesparrec in
let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in
- let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in
+ let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in
let eqI, eff = eqI ind lnamesparrec in
let create_input c =
let x = next_ident_away (Id.of_string "x") avoid and
@@ -722,7 +731,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec =
( List.map (fun (_,_,_,slb) -> slb) list_id )
in
let fresh_id s gl =
- let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in
+ let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in
avoid := fresh::(!avoid); fresh
in
Proofview.Goal.enter begin fun gl ->
@@ -739,9 +748,9 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec =
intro_using freshz;
intros;
Tacticals.New.tclTRY (
- Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None)
+ Tacticals.New.tclORELSE reflexivity my_discr_tac
);
- Equality.inj None false None (EConstr.mkVar freshz,NoBindings);
+ my_inj_tac freshz;
intros; simpl_in_concl;
Auto.default_auto;
Tacticals.New.tclREPEAT (
@@ -806,7 +815,7 @@ let compute_dec_goal ind lnamesparrec nparrec =
check_not_is_defined ();
let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in
let list_id = list_id lnamesparrec in
- let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in
+ let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in
let create_input c =
let x = next_ident_away (Id.of_string "x") avoid and
y = next_ident_away (Id.of_string "y") avoid in
@@ -870,7 +879,7 @@ let compute_dec_tact ind lnamesparrec nparrec =
( List.map (fun (_,_,_,slb) -> slb) list_id )
in
let fresh_id s gl =
- let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in
+ let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in
avoid := fresh::(!avoid); fresh
in
Proofview.Goal.enter begin fun gl ->
@@ -936,7 +945,7 @@ let compute_dec_tact ind lnamesparrec nparrec =
NoBindings
)
true;
- Equality.discr_tac false None
+ my_discr_tac
]
end
]
diff --git a/vernac/class.ml b/vernac/class.ml
index be682977e5..3915148a08 100644
--- a/vernac/class.ml
+++ b/vernac/class.ml
@@ -222,9 +222,10 @@ let build_id_coercion idf_opt source poly =
Id.of_string ("Id_"^(ident_key_of_class source)^"_"^
(ident_key_of_class cl))
in
+ let univs = (snd (Evd.universe_context ~names:[] ~extensible:true sigma)) in
let constr_entry = (* Cast is necessary to express [val_f] is identity *)
DefinitionEntry
- (definition_entry ~types:typ_f ~poly ~univs:(snd (Evd.universe_context sigma))
+ (definition_entry ~types:typ_f ~poly ~univs
~inline:true (mkCast (val_f, DEFAULTcast, typ_f)))
in
let decl = (constr_entry, IsDefinition IdentityCoercion) in
diff --git a/vernac/classes.ml b/vernac/classes.ml
index ab1892a18e..0926c93e57 100644
--- a/vernac/classes.ml
+++ b/vernac/classes.ml
@@ -111,14 +111,14 @@ let instance_hook k info global imps ?hook cst =
Typeclasses.declare_instance (Some info) (not global) cst;
(match hook with Some h -> h cst | None -> ())
-let declare_instance_constant k info global imps ?hook id pl poly evm term termtype =
+let declare_instance_constant k info global imps ?hook id decl poly evm term termtype =
let kind = IsDefinition Instance in
let evm =
let levels = Univ.LSet.union (Univops.universes_of_constr termtype)
(Univops.universes_of_constr term) in
Evd.restrict_universe_context evm levels
in
- let pl, uctx = Evd.universe_context ?names:pl evm in
+ let pl, uctx = Evd.check_univ_decl evm decl in
let entry =
Declare.definition_entry ~types:termtype ~poly ~univs:uctx term
in
@@ -129,13 +129,13 @@ let declare_instance_constant k info global imps ?hook id pl poly evm term termt
instance_hook k info global imps ?hook (ConstRef kn);
id
-let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) poly ctx (instid, bk, cl) props
- ?(generalize=true)
- ?(tac:unit Proofview.tactic option) ?hook pri =
+let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance)
+ poly ctx (instid, bk, cl) props ?(generalize=true)
+ ?(tac:unit Proofview.tactic option) ?hook pri =
let env = Global.env() in
let ((loc, instid), pl) = instid in
- let uctx = Evd.make_evar_universe_context env pl in
- let evars = ref (Evd.from_ctx uctx) in
+ let evd, decl = Univdecls.interp_univ_decl_opt env pl in
+ let evars = ref evd in
let tclass, ids =
match bk with
| Decl_kinds.Implicit ->
@@ -183,7 +183,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p
id
| Anonymous ->
let i = Nameops.add_suffix (id_of_class k) "_instance_0" in
- Namegen.next_global_ident_away i (Termops.ids_of_context env)
+ Namegen.next_global_ident_away i (Termops.vars_of_env env)
in
let env' = push_rel_context ctx env in
evars := Evarutil.nf_evar_map !evars;
@@ -202,7 +202,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p
nf t
in
Pretyping.check_evars env Evd.empty !evars (EConstr.of_constr termtype);
- let pl, ctx = Evd.universe_context ?names:pl !evars in
+ let pl, ctx = Evd.check_univ_decl !evars decl in
let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id
(ParameterEntry
(None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical)
@@ -302,7 +302,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p
in
let term = Option.map nf term in
if not (Evd.has_undefined evm) && not (Option.is_empty term) then
- declare_instance_constant k pri global imps ?hook id pl
+ declare_instance_constant k pri global imps ?hook id decl
poly evm (Option.get term) termtype
else if Flags.is_program_mode () || refine || Option.is_empty term then begin
let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in
@@ -323,7 +323,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p
let hook = Lemmas.mk_hook hook in
let ctx = Evd.evar_universe_context evm in
ignore (Obligations.add_definition id ?term:constr
- ?pl typ ctx ~kind:(Global,poly,Instance) ~hook obls);
+ ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls);
id
else
(Flags.silently
@@ -334,7 +334,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p
the refinement manually.*)
let gls = List.rev (Evd.future_goals evm) in
let evm = Evd.reset_future_goals evm in
- Lemmas.start_proof id ?pl kind evm (EConstr.of_constr termtype)
+ Lemmas.start_proof id ~pl:decl kind evm (EConstr.of_constr termtype)
(Lemmas.mk_hook
(fun _ -> instance_hook k pri global imps ?hook));
(* spiwack: I don't know what to do with the status here. *)
diff --git a/vernac/classes.mli b/vernac/classes.mli
index fc2fdbbf34..fcdb5c3bc5 100644
--- a/vernac/classes.mli
+++ b/vernac/classes.mli
@@ -30,7 +30,7 @@ val declare_instance_constant :
Impargs.manual_explicitation list -> (** implicits *)
?hook:(Globnames.global_reference -> unit) ->
Id.t -> (** name *)
- Id.t Loc.located list option ->
+ Univdecls.universe_decl ->
bool -> (* polymorphic *)
Evd.evar_map -> (* Universes *)
Constr.t -> (** body *)
@@ -43,7 +43,7 @@ val new_instance :
?refine:bool -> (** Allow refinement *)
Decl_kinds.polymorphic ->
local_binder_expr list ->
- typeclass_constraint ->
+ Vernacexpr.typeclass_constraint ->
(bool * constr_expr) option ->
?generalize:bool ->
?tac:unit Proofview.tactic ->
diff --git a/vernac/command.ml b/vernac/command.ml
index e04bebe33b..f58ed065c6 100644
--- a/vernac/command.ml
+++ b/vernac/command.ml
@@ -9,7 +9,6 @@
open Pp
open CErrors
open Util
-open Flags
open Term
open Vars
open Termops
@@ -80,7 +79,7 @@ let red_constant_entry n ce sigma = function
let (_, c) = redfun env sigma c in
EConstr.Unsafe.to_constr c
in
- { ce with const_entry_body = Future.chain ~pure:true proof_out
+ { ce with const_entry_body = Future.chain proof_out
(fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) }
let warn_implicits_in_term =
@@ -91,8 +90,8 @@ let warn_implicits_in_term =
let interp_definition pl bl p red_option c ctypopt =
let env = Global.env() in
- let ctx = Evd.make_evar_universe_context env pl in
- let evdref = ref (Evd.from_ctx ctx) in
+ let evd, decl = Univdecls.interp_univ_decl_opt env pl in
+ let evdref = ref evd in
let impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in
let ctx = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx in
let nb_args = Context.Rel.nhyps ctx in
@@ -108,7 +107,7 @@ let interp_definition pl bl p red_option c ctypopt =
let body = nf (it_mkLambda_or_LetIn c ctx) in
let vars = Univops.universes_of_constr body in
let evd = Evd.restrict_universe_context !evdref vars in
- let pl, uctx = Evd.universe_context ?names:pl evd in
+ let pl, uctx = Evd.check_univ_decl evd decl in
imps1@(Impargs.lift_implicits nb_args imps2), pl,
definition_entry ~univs:uctx ~poly:p body
| Some ctyp ->
@@ -134,20 +133,20 @@ let interp_definition pl bl p red_option c ctypopt =
let vars = Univ.LSet.union (Univops.universes_of_constr body)
(Univops.universes_of_constr typ) in
let ctx = Evd.restrict_universe_context !evdref vars in
- let pl, uctx = Evd.universe_context ?names:pl ctx in
+ let pl, uctx = Evd.check_univ_decl ctx decl in
imps1@(Impargs.lift_implicits nb_args impsty), pl,
definition_entry ~types:typ ~poly:p
~univs:uctx body
in
- red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, pl, imps
+ red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, decl, pl, imps
-let check_definition (ce, evd, _, imps) =
+let check_definition (ce, evd, _, _, imps) =
check_evars_are_solved (Global.env ()) evd Evd.empty;
ce
-let do_definition ident k pl bl red_option c ctypopt hook =
- let (ce, evd, pl', imps as def) =
- interp_definition pl bl (pi2 k) red_option c ctypopt
+let do_definition ident k univdecl bl red_option c ctypopt hook =
+ let (ce, evd, univdecl, pl', imps as def) =
+ interp_definition univdecl bl (pi2 k) red_option c ctypopt
in
if Flags.is_program_mode () then
let env = Global.env () in
@@ -164,8 +163,8 @@ let do_definition ident k pl bl red_option c ctypopt hook =
in
let ctx = Evd.evar_universe_context evd in
let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in
- ignore(Obligations.add_definition
- ident ~term:c cty ctx ?pl ~implicits:imps ~kind:k ~hook obls)
+ ignore(Obligations.add_definition
+ ident ~term:c cty ctx ~univdecl ~implicits:imps ~kind:k ~hook obls)
else let ce = check_definition def in
ignore(DeclareDef.declare_definition ident k ce pl' imps
(Lemmas.mk_hook
@@ -241,7 +240,7 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l =
else l
in
(* We intepret all declarations in the same evar_map, i.e. as a telescope. *)
- let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) ->
+ let _,l = List.fold_left_map (fun (env,ienv) (is_coe,(idl,c)) ->
let t,imps = interp_assumption evdref env ienv [] c in
let env =
push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in
@@ -270,15 +269,15 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l =
let do_assumptions_bound_univs coe kind nl id pl c =
let env = Global.env () in
- let ctx = Evd.make_evar_universe_context env pl in
- let evdref = ref (Evd.from_ctx ctx) in
+ let evd, decl = Univdecls.interp_univ_decl_opt env pl in
+ let evdref = ref evd in
let ty, impls = interp_type_evars_impls env evdref c in
let nf, subst = Evarutil.e_nf_evars_and_universes evdref in
let ty = EConstr.Unsafe.to_constr ty in
let ty = nf ty in
let vars = Univops.universes_of_constr ty in
let evd = Evd.restrict_universe_context !evdref vars in
- let pl, uctx = Evd.universe_context ?names:pl evd in
+ let pl, uctx = Evd.check_univ_decl evd decl in
let uctx = Univ.ContextSet.of_context uctx in
let (_, _, st) = declare_assumption coe kind (ty, uctx) pl impls false nl id in
st
@@ -318,7 +317,7 @@ let push_types env idl tl =
type structured_one_inductive_expr = {
ind_name : Id.t;
- ind_univs : lident list option;
+ ind_univs : Vernacexpr.universe_decl_expr option;
ind_arity : constr_expr;
ind_lc : (Id.t * constr_expr) list
}
@@ -367,7 +366,7 @@ let prepare_param = function
let rec check_anonymous_type ind =
let open Glob_term in
- match ind.CAst.v with
+ match DAst.get ind with
| GSort (GType []) -> true
| GProd ( _, _, _, e)
| GLetIn (_, _, _, e)
@@ -393,8 +392,9 @@ let is_impredicative env u =
let interp_ind_arity env evdref ind =
let c = intern_gen IsType env ind.ind_arity in
- let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in
- let t, impls = understand_tcc_evars env evdref ~expected_type:IsType c, imps in
+ let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in
+ let (evd,t) = understand_tcc env !evdref ~expected_type:IsType c in
+ evdref := evd;
let pseudo_poly = check_anonymous_type c in
let () = if not (Reductionops.is_arity env !evdref t) then
user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity")
@@ -518,15 +518,16 @@ let check_param = function
| CLocalDef (na, _, _) -> check_named na
| CLocalAssum (nas, Default _, _) -> List.iter check_named nas
| CLocalAssum (nas, Generalized _, _) -> ()
-| CLocalPattern _ -> assert false
+| CLocalPattern (loc,_) ->
+ Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.")
let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite =
check_all_names_different indl;
List.iter check_param paramsl;
let env0 = Global.env() in
let pl = (List.hd indl).ind_univs in
- let ctx = Evd.make_evar_universe_context env0 pl in
- let evdref = ref Evd.(from_ctx ctx) in
+ let evd, decl = Univdecls.interp_univ_decl_opt env0 pl in
+ let evdref = ref evd in
let impls, ((env_params, ctx_params), userimpls) =
interp_context_evars env0 evdref paramsl
in
@@ -549,13 +550,12 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite =
lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in
let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in
let impls = compute_internalization_env env0 ~impls (Inductive (params,true)) indnames fullarities indimpls in
- let implsforntn = compute_internalization_env env0 Variable indnames fullarities indimpls in
let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in
let constructors =
Metasyntax.with_syntax_protection (fun () ->
(* Temporary declaration of notations and scopes *)
- List.iter (Metasyntax.set_notation_for_interpretation implsforntn) notations;
+ List.iter (Metasyntax.set_notation_for_interpretation env_params impls) notations;
(* Interpret the constructor types *)
List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl)
() in
@@ -575,7 +575,7 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite =
let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in
let ctx_params = Context.Rel.map nf ctx_params in
let evd = !evdref in
- let pl, uctx = Evd.universe_context ?names:pl evd in
+ let pl, uctx = Evd.check_univ_decl evd decl in
List.iter (fun c -> check_evars env_params Evd.empty evd (EConstr.of_constr c)) arities;
Context.Rel.iter (fun c -> check_evars env0 Evd.empty evd (EConstr.of_constr c)) ctx_params;
List.iter (fun (_,ctyps,_) ->
@@ -691,7 +691,7 @@ let declare_mutual_inductive_with_eliminations mie pl impls =
constrimpls)
impls;
let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in
- if_verbose Feedback.msg_info (minductive_message warn_prim names);
+ Flags.if_verbose Feedback.msg_info (minductive_message warn_prim names);
if mie.mind_entry_private == None
then declare_default_schemes mind;
mind
@@ -707,7 +707,7 @@ let do_mutual_inductive indl cum poly prv finite =
(* Declare the mutual inductive block with its associated schemes *)
ignore (declare_mutual_inductive_with_eliminations mie pl impls);
(* Declare the possible notations of inductive types *)
- List.iter Metasyntax.add_notation_interpretation ntns;
+ List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns;
(* Declare the coercions *)
List.iter (fun qid -> Class.try_add_new_coercion (locate qid) ~local:false poly) coes;
(* If positivity is assumed declares itself as unsafe. *)
@@ -796,7 +796,7 @@ let check_mutuality env evd isfix fixl =
type structured_fixpoint_expr = {
fix_name : Id.t;
- fix_univs : lident list option;
+ fix_univs : universe_decl_expr option;
fix_annot : Id.t Loc.located option;
fix_binders : local_binder_expr list;
fix_body : constr_expr option;
@@ -916,8 +916,8 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in
Coqlib.check_required_library ["Coq";"Program";"Wf"];
let env = Global.env() in
- let ctx = Evd.make_evar_universe_context env pl in
- let evdref = ref (Evd.from_ctx ctx) in
+ let evd, decl = Univdecls.interp_univ_decl_opt env pl in
+ let evdref = ref evd in
let _, ((env', binders_rel), impls) = interp_context_evars env evdref bl in
let len = List.length binders_rel in
let top_env = push_rel_context binders_rel env in
@@ -1018,14 +1018,16 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
let binders_rel = nf_evar_context !evdref binders_rel in
let binders = nf_evar_context !evdref binders in
let top_arity = Evarutil.nf_evar !evdref top_arity in
- let hook, recname, typ =
+ let pl, plext = Option.cata
+ (fun d -> d.univdecl_instance, d.univdecl_extensible_instance) ([],true) pl in
+ let hook, recname, typ =
if List.length binders_rel > 1 then
let name = add_suffix recname "_func" in
let hook l gr _ =
let body = it_mkLambda_or_LetIn (mkApp (Evarutil.e_new_global evdref gr, [|make|])) binders_rel in
let ty = it_mkProd_or_LetIn top_arity binders_rel in
let ty = EConstr.Unsafe.to_constr ty in
- let pl, univs = Evd.universe_context ?names:pl !evdref in
+ let pl, univs = Evd.universe_context ~names:pl ~extensible:plext !evdref in
(*FIXME poly? *)
let ce = definition_entry ~poly ~types:ty ~univs (EConstr.to_constr !evdref body) in
(** FIXME: include locality *)
@@ -1051,7 +1053,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp
in
let ctx = Evd.evar_universe_context !evdref in
- ignore(Obligations.add_definition recname ~term:evars_def ?pl
+ ignore(Obligations.add_definition recname ~term:evars_def ~univdecl:decl
evars_typ ctx evars ~hook)
let interp_recursive isfix fixl notations =
@@ -1067,11 +1069,12 @@ let interp_recursive isfix fixl notations =
| None , acc -> acc
| x , None -> x
| Some ls , Some us ->
- if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) ls us) then
+ let lsu = ls.univdecl_instance and usu = us.univdecl_instance in
+ if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) lsu usu) then
user_err Pp.(str "(co)-recursive definitions should all have the same universe binders");
Some us) fixl None in
- let ctx = Evd.make_evar_universe_context env all_universes in
- let evdref = ref (Evd.from_ctx ctx) in
+ let evd, decl = Univdecls.interp_univ_decl_opt env all_universes in
+ let evdref = ref evd in
let fixctxs, fiximppairs, fixannots =
List.split3 (List.map (interp_fix_context env evdref isfix) fixl) in
let fixctximpenvs, fixctximps = List.split fiximppairs in
@@ -1106,7 +1109,7 @@ let interp_recursive isfix fixl notations =
(* Interp bodies with rollback because temp use of notations/implicit *)
let fixdefs =
Metasyntax.with_syntax_protection (fun () ->
- List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
+ List.iter (Metasyntax.set_notation_for_interpretation env_rec impls) notations;
List.map4
(fun fixctximpenv -> interp_fix_body env_rec evdref (Id.Map.fold Id.Map.add fixctximpenv impls))
fixctximpenvs fixctxs fixl fixccls)
@@ -1121,7 +1124,7 @@ let interp_recursive isfix fixl notations =
let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in
(* Build the fix declaration block *)
- (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots
+ (env,rec_sign,decl,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots
let check_recursive isfix env evd (fixnames,fixdefs,_) =
check_evars_are_solved env evd Evd.empty;
@@ -1144,14 +1147,14 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind
if List.exists Option.is_empty fixdefs then
(* Some bodies to define by proof *)
let thms =
- List.map3 (fun id t (ctx,imps,_) -> ((id,pl),(t,(List.map RelDecl.get_name ctx,imps))))
+ List.map3 (fun id t (ctx,imps,_) -> (id,(t,(List.map RelDecl.get_name ctx,imps))))
fixnames fixtypes fiximps in
let init_tac =
Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC)
fixdefs) in
let evd = Evd.from_ctx ctx in
Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint)
- evd (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ()))
+ evd pl (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ()))
else begin
(* We shortcut the proof process *)
let fixdefs = List.map Option.get fixdefs in
@@ -1164,28 +1167,28 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind
List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in
let evd = Evd.from_ctx ctx in
let evd = Evd.restrict_universe_context evd vars in
+ let pl, ctx = Evd.check_univ_decl evd pl in
let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in
- let pl, ctx = Evd.universe_context ?names:pl evd in
ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx)
fixnames fixdecls fixtypes fiximps);
(* Declare the recursive definitions *)
fixpoint_message (Some indexes) fixnames;
end;
(* Declare notations *)
- List.iter Metasyntax.add_notation_interpretation ntns
+ List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns
let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns =
if List.exists Option.is_empty fixdefs then
(* Some bodies to define by proof *)
let thms =
- List.map3 (fun id t (ctx,imps,_) -> ((id,pl),(t,(List.map RelDecl.get_name ctx,imps))))
+ List.map3 (fun id t (ctx,imps,_) -> (id,(t,(List.map RelDecl.get_name ctx,imps))))
fixnames fixtypes fiximps in
let init_tac =
Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC)
fixdefs) in
let evd = Evd.from_ctx ctx in
Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint)
- evd (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ()))
+ evd pl (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ()))
else begin
(* We shortcut the proof process *)
let fixdefs = List.map Option.get fixdefs in
@@ -1196,14 +1199,14 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n
let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in
let evd = Evd.from_ctx ctx in
let evd = Evd.restrict_universe_context evd vars in
- let pl, ctx = Evd.universe_context ?names:pl evd in
- ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx)
+ let pl, ctx = Evd.check_univ_decl evd pl in
+ ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx)
fixnames fixdecls fixtypes fiximps);
(* Declare the recursive definitions *)
cofixpoint_message fixnames
end;
(* Declare notations *)
- List.iter Metasyntax.add_notation_interpretation ntns
+ List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns
let extract_decreasing_argument limit = function
| (na,CStructRec) -> na
@@ -1280,7 +1283,7 @@ let do_program_recursive local p fixkind fixl ntns =
| Obligations.IsFixpoint _ -> (local, p, Fixpoint)
| Obligations.IsCoFixpoint -> (local, p, CoFixpoint)
in
- Obligations.add_mutual_definitions defs ~kind ?pl ctx ntns fixkind
+ Obligations.add_mutual_definitions defs ~kind ~univdecl:pl ctx ntns fixkind
let do_program_fixpoint local poly l =
let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
diff --git a/vernac/command.mli b/vernac/command.mli
index 8d17f27c30..afa97aa24f 100644
--- a/vernac/command.mli
+++ b/vernac/command.mli
@@ -26,11 +26,11 @@ val do_constraint : polymorphic ->
(** {6 Definitions/Let} *)
val interp_definition :
- lident list option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr ->
+ Vernacexpr.universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr ->
constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map *
- Universes.universe_binders * Impargs.manual_implicits
+ Univdecls.universe_decl * Universes.universe_binders * Impargs.manual_implicits
-val do_definition : Id.t -> definition_kind -> lident list option ->
+val do_definition : Id.t -> definition_kind -> Vernacexpr.universe_decl_expr option ->
local_binder_expr list -> red_expr option -> constr_expr ->
constr_expr option -> unit Lemmas.declaration_hook -> unit
@@ -49,7 +49,7 @@ val declare_assumption : coercion_flag -> assumption_kind ->
global_reference * Univ.Instance.t * bool
val do_assumptions : locality * polymorphic * assumption_object_kind ->
- Vernacexpr.inline -> (plident list * constr_expr) with_coercion list -> bool
+ Vernacexpr.inline -> (Vernacexpr.ident_decl list * constr_expr) with_coercion list -> bool
(* val declare_assumptions : variable Loc.located list -> *)
(* coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> *)
@@ -62,7 +62,7 @@ val do_assumptions : locality * polymorphic * assumption_object_kind ->
type structured_one_inductive_expr = {
ind_name : Id.t;
- ind_univs : lident list option;
+ ind_univs : Vernacexpr.universe_decl_expr option;
ind_arity : constr_expr;
ind_lc : (Id.t * constr_expr) list
}
@@ -102,7 +102,7 @@ val do_mutual_inductive :
type structured_fixpoint_expr = {
fix_name : Id.t;
- fix_univs : lident list option;
+ fix_univs : Vernacexpr.universe_decl_expr option;
fix_annot : Id.t Loc.located option;
fix_binders : local_binder_expr list;
fix_body : constr_expr option;
@@ -127,24 +127,24 @@ type recursive_preentry =
val interp_fixpoint :
structured_fixpoint_expr list -> decl_notation list ->
- recursive_preentry * lident list option * Evd.evar_universe_context *
+ recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context *
(EConstr.rel_context * Impargs.manual_implicits * int option) list
val interp_cofixpoint :
structured_fixpoint_expr list -> decl_notation list ->
- recursive_preentry * lident list option * Evd.evar_universe_context *
+ recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context *
(EConstr.rel_context * Impargs.manual_implicits * int option) list
(** Registering fixpoints and cofixpoints in the environment *)
val declare_fixpoint :
locality -> polymorphic ->
- recursive_preentry * lident list option * Evd.evar_universe_context *
+ recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context *
(Context.Rel.t * Impargs.manual_implicits * int option) list ->
Proof_global.lemma_possible_guards -> decl_notation list -> unit
val declare_cofixpoint : locality -> polymorphic ->
- recursive_preentry * lident list option * Evd.evar_universe_context *
+ recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context *
(Context.Rel.t * Impargs.manual_implicits * int option) list ->
decl_notation list -> unit
diff --git a/vernac/discharge.ml b/vernac/discharge.ml
deleted file mode 100644
index 474c0b4dd2..0000000000
--- a/vernac/discharge.ml
+++ /dev/null
@@ -1,122 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open CErrors
-open Util
-open Term
-open Vars
-open Declarations
-open Cooking
-open Entries
-open Context.Rel.Declaration
-
-(********************************)
-(* Discharging mutual inductive *)
-
-let detype_param =
- function
- | LocalAssum (Name id, p) -> id, LocalAssumEntry p
- | LocalDef (Name id, p,_) -> id, LocalDefEntry p
- | _ -> anomaly (Pp.str "Unnamed inductive local variable.")
-
-(* Replace
-
- Var(y1)..Var(yq):C1..Cq |- Ij:Bj
- Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti
-
- by
-
- |- Ij: (y1..yq:C1..Cq)Bj
- I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)]
-*)
-
-let abstract_inductive hyps nparams inds =
- let ntyp = List.length inds in
- let nhyp = Context.Named.length hyps in
- let args = Context.Named.to_instance mkVar (List.rev hyps) in
- let args = Array.of_list args in
- let subs = List.init ntyp (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) in
- let inds' =
- List.map
- (function (tname,arity,template,cnames,lc) ->
- let lc' = List.map (substl subs) lc in
- let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in
- let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in
- (tname,arity',template,cnames,lc''))
- inds in
- let nparams' = nparams + Array.length args in
-(* To be sure to be the same as before, should probably be moved to process_inductive *)
- let params' = let (_,arity,_,_,_) = List.hd inds' in
- let (params,_) = decompose_prod_n_assum nparams' arity in
- List.map detype_param params
- in
- let ind'' =
- List.map
- (fun (a,arity,template,c,lc) ->
- let _, short_arity = decompose_prod_n_assum nparams' arity in
- let shortlc =
- List.map (fun c -> snd (decompose_prod_n_assum nparams' c)) lc in
- { mind_entry_typename = a;
- mind_entry_arity = short_arity;
- mind_entry_template = template;
- mind_entry_consnames = c;
- mind_entry_lc = shortlc })
- inds'
- in (params',ind'')
-
-let refresh_polymorphic_type_of_inductive (_,mip) =
- match mip.mind_arity with
- | RegularArity s -> s.mind_user_arity, false
- | TemplateArity ar ->
- let ctx = List.rev mip.mind_arity_ctxt in
- mkArity (List.rev ctx, Type ar.template_level), true
-
-let process_inductive (sechyps,_,_ as info) modlist mib =
- let sechyps = Lib.named_of_variable_context sechyps in
- let nparams = mib.mind_nparams in
- let subst, ind_univs =
- match mib.mind_universes with
- | Monomorphic_ind ctx -> Univ.empty_level_subst, Monomorphic_ind_entry ctx
- | Polymorphic_ind auctx ->
- let subst, auctx = Lib.discharge_abstract_universe_context info auctx in
- let auctx = Univ.AUContext.repr auctx in
- subst, Polymorphic_ind_entry auctx
- | Cumulative_ind cumi ->
- let auctx = Univ.ACumulativityInfo.univ_context cumi in
- let subst, auctx = Lib.discharge_abstract_universe_context info auctx in
- let auctx = Univ.AUContext.repr auctx in
- subst, Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context auctx)
- in
- let discharge c = Vars.subst_univs_level_constr subst (expmod_constr modlist c) in
- let inds =
- Array.map_to_list
- (fun mip ->
- let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in
- let arity = discharge ty in
- let lc = Array.map discharge mip.mind_user_lc in
- (mip.mind_typename,
- arity, template,
- Array.to_list mip.mind_consnames,
- Array.to_list lc))
- mib.mind_packets in
- let sechyps' = Context.Named.map discharge sechyps in
- let (params',inds') = abstract_inductive sechyps' nparams inds in
- let record = match mib.mind_record with
- | Some (Some (id, _, _)) -> Some (Some id)
- | Some None -> Some None
- | None -> None
- in
- { mind_entry_record = record;
- mind_entry_finite = mib.mind_finite;
- mind_entry_params = params';
- mind_entry_inds = inds';
- mind_entry_private = mib.mind_private;
- mind_entry_universes = ind_univs
- }
-
diff --git a/vernac/himsg.ml b/vernac/himsg.ml
index 2be10a0397..189c47aab9 100644
--- a/vernac/himsg.ml
+++ b/vernac/himsg.ml
@@ -84,7 +84,7 @@ let rec contract3' env sigma a b c = function
(** Ad-hoc reductions *)
let j_nf_betaiotaevar sigma j =
- { uj_val = Evarutil.nf_evar sigma j.uj_val;
+ { uj_val = j.uj_val;
uj_type = Reductionops.nf_betaiota sigma j.uj_type }
let jv_nf_betaiotaevar sigma jl =
@@ -173,7 +173,6 @@ let explain_unbound_var env v =
str "No such section variable or assumption: " ++ var ++ str "."
let explain_not_type env sigma j =
- let j = Evarutil.j_nf_evar sigma j in
let pe = pr_ne_context_of (str "In environment") env sigma in
let pc,pt = pr_ljudge_env env sigma j in
pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++
@@ -241,7 +240,6 @@ let explain_elim_arity env sigma ind sorts c pj okinds =
fnl () ++ msg
let explain_case_not_inductive env sigma cj =
- let cj = Evarutil.j_nf_evar sigma cj in
let env = make_all_name_different env sigma in
let pc = pr_leconstr_env env sigma cj.uj_val in
let pct = pr_leconstr_env env sigma cj.uj_type in
@@ -254,7 +252,6 @@ let explain_case_not_inductive env sigma cj =
str "which is not a (co-)inductive type."
let explain_number_branches env sigma cj expn =
- let cj = Evarutil.j_nf_evar sigma cj in
let env = make_all_name_different env sigma in
let pc = pr_leconstr_env env sigma cj.uj_val in
let pct = pr_leconstr_env env sigma cj.uj_type in
@@ -263,7 +260,7 @@ let explain_number_branches env sigma cj expn =
str "expects " ++ int expn ++ str " branches."
let explain_ill_formed_branch env sigma c ci actty expty =
- let simp t = Reductionops.nf_betaiota sigma (Evarutil.nf_evar sigma t) in
+ let simp t = Reductionops.nf_betaiota sigma t in
let env = make_all_name_different env sigma in
let pc = pr_leconstr_env env sigma c in
let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in
@@ -300,10 +297,10 @@ let explain_unification_error env sigma p1 p2 = function
| NotSameArgSize | NotSameHead | NoCanonicalStructure ->
(* Error speaks from itself *) []
| ConversionFailed (env,t1,t2) ->
+ let t1 = Reductionops.nf_betaiota sigma t1 in
+ let t2 = Reductionops.nf_betaiota sigma t2 in
if EConstr.eq_constr sigma t1 p1 && EConstr.eq_constr sigma t2 p2 then [] else
let env = make_all_name_different env sigma in
- let t1 = Evarutil.nf_evar sigma t1 in
- let t2 = Evarutil.nf_evar sigma t2 in
if not (EConstr.eq_constr sigma t1 p1) || not (EConstr.eq_constr sigma t2 p2) then
let t1, t2 = pr_explicit env sigma t1 t2 in
[str "cannot unify " ++ t1 ++ strbrk " and " ++ t2]
@@ -327,8 +324,6 @@ let explain_unification_error env sigma p1 p2 = function
| CannotSolveConstraint ((pb,env,t,u),e) ->
let t = EConstr.of_constr t in
let u = EConstr.of_constr u in
- let t = Evarutil.nf_evar sigma t in
- let u = Evarutil.nf_evar sigma u in
let env = make_all_name_different env sigma in
(strbrk "cannot satisfy constraint " ++ pr_leconstr_env env sigma t ++
str " == " ++ pr_leconstr_env env sigma u)
@@ -359,9 +354,7 @@ let explain_actual_type env sigma j t reason =
let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl =
let randl = jv_nf_betaiotaevar sigma randl in
- let exptyp = Evarutil.nf_evar sigma exptyp in
let actualtyp = Reductionops.nf_betaiota sigma actualtyp in
- let rator = Evarutil.j_nf_evar sigma rator in
let env = make_all_name_different env sigma in
let actualtyp, exptyp = pr_explicit env sigma actualtyp exptyp in
let nargs = Array.length randl in
@@ -386,8 +379,6 @@ let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl =
exptyp ++ str "."
let explain_cant_apply_not_functional env sigma rator randl =
- let randl = Evarutil.jv_nf_evar sigma randl in
- let rator = Evarutil.j_nf_evar sigma rator in
let env = make_all_name_different env sigma in
let nargs = Array.length randl in
(* let pe = pr_ne_context_of (str "in environment") env sigma in*)
@@ -407,8 +398,6 @@ let explain_cant_apply_not_functional env sigma rator randl =
fnl () ++ str " " ++ v 0 appl
let explain_unexpected_type env sigma actual_type expected_type =
- let actual_type = Evarutil.nf_evar sigma actual_type in
- let expected_type = Evarutil.nf_evar sigma expected_type in
let pract, prexp = pr_explicit env sigma actual_type expected_type in
str "Found type" ++ spc () ++ pract ++ spc () ++
str "where" ++ spc () ++ prexp ++ str " was expected."
@@ -418,7 +407,7 @@ let explain_not_product env sigma c =
let pr = pr_lconstr_env env sigma c in
str "The type of this term is a product" ++ spc () ++
str "while it is expected to be" ++
- (if is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "."
+ (if Term.is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "."
(* TODO: use the names *)
(* (co)fixpoints *)
@@ -510,8 +499,6 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj =
with e when CErrors.noncritical e -> mt ())
let explain_ill_typed_rec_body env sigma i names vdefj vargs =
- let vdefj = Evarutil.jv_nf_evar sigma vdefj in
- let vargs = Array.map (Evarutil.nf_evar sigma) vargs in
let env = make_all_name_different env sigma in
let pvd = pr_leconstr_env env sigma vdefj.(i).uj_val in
let pvdt, pv = pr_explicit env sigma vdefj.(i).uj_type vargs.(i) in
@@ -575,9 +562,9 @@ let rec explain_evar_kind env sigma evk ty = function
| Evar_kinds.SubEvar evk' ->
let evi = Evd.find sigma evk' in
let pc = match evi.evar_body with
- | Evar_defined c -> pr_leconstr_env env sigma (Evarutil.nf_evar sigma (EConstr.of_constr c))
+ | Evar_defined c -> pr_leconstr_env env sigma (EConstr.of_constr c)
| Evar_empty -> assert false in
- let ty' = Evarutil.nf_evar sigma (EConstr.of_constr evi.evar_concl) in
+ let ty' = EConstr.of_constr evi.evar_concl in
pr_existential_key sigma evk ++ str " of type " ++ ty ++
str " in the partial instance " ++ pc ++
str " found for " ++ explain_evar_kind env sigma evk'
@@ -628,8 +615,6 @@ let explain_wrong_case_info env (ind,u) ci =
let explain_cannot_unify env sigma m n e =
let env = make_all_name_different env sigma in
- let m = Evarutil.nf_evar sigma m in
- let n = Evarutil.nf_evar sigma n in
let pm, pn = pr_explicit env sigma m n in
let ppreason = explain_unification_error env sigma m n e in
let pe = pr_ne_context_of (str "In environment") env sigma in
@@ -1176,7 +1161,7 @@ let error_not_allowed_case_analysis isrec kind i =
pr_inductive (Global.env()) (fst i) ++ str "."
let error_not_allowed_dependent_analysis isrec i =
- str "Dependent " ++ str (if isrec then "Induction" else "Case analysis") ++
+ str "Dependent " ++ str (if isrec then "induction" else "case analysis") ++
strbrk " is not allowed for inductive definition " ++
pr_inductive (Global.env()) i ++ str "."
diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml
index 6ea8bc7f2c..90168843a6 100644
--- a/vernac/indschemes.ml
+++ b/vernac/indschemes.ml
@@ -30,7 +30,6 @@ open Globnames
open Goptions
open Nameops
open Termops
-open Pretyping
open Nametab
open Smartlocate
open Vernacexpr
@@ -109,7 +108,7 @@ let _ =
let define id internal ctx c t =
let f = declare_constant ~internal in
- let _, univs = Evd.universe_context ctx in
+ let _, univs = Evd.universe_context ~names:[] ~extensible:true ctx in
let univs =
if Flags.is_universe_polymorphism () then Polymorphic_const_entry univs
else Monomorphic_const_entry univs
@@ -345,24 +344,23 @@ requested
let names inds recs isdep y z =
let ind = smart_global_inductive y in
let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in
- let z' = interp_elimination_sort z in
let suffix = (
match sort_of_ind with
| InProp ->
- if isdep then (match z' with
+ if isdep then (match z with
| InProp -> inds ^ "_dep"
| InSet -> recs ^ "_dep"
| InType -> recs ^ "t_dep")
- else ( match z' with
+ else ( match z with
| InProp -> inds
| InSet -> recs
| InType -> recs ^ "t" )
| _ ->
- if isdep then (match z' with
+ if isdep then (match z with
| InProp -> inds
| InSet -> recs
| InType -> recs ^ "t" )
- else (match z' with
+ else (match z with
| InProp -> inds ^ "_nodep"
| InSet -> recs ^ "_nodep"
| InType -> recs ^ "t_nodep")
@@ -392,7 +390,7 @@ let do_mutual_induction_scheme lnamedepindsort =
evd, (ind,u), Some u
| Some ui -> evd, (ind, ui), inst
in
- (evd, (indu,dep,interp_elimination_sort sort) :: l, inst))
+ (evd, (indu,dep,sort) :: l, inst))
lnamedepindsort (Evd.from_env env0,[],None)
in
let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in
diff --git a/vernac/indschemes.mli b/vernac/indschemes.mli
index 076e4938fd..91c4c58255 100644
--- a/vernac/indschemes.mli
+++ b/vernac/indschemes.mli
@@ -11,7 +11,6 @@ open Names
open Term
open Environ
open Vernacexpr
-open Misctypes
(** See also Auto_ind_decl, Indrec, Eqscheme, Ind_tables, ... *)
@@ -32,7 +31,7 @@ val declare_rewriting_schemes : inductive -> unit
(** Mutual Minimality/Induction scheme *)
val do_mutual_induction_scheme :
- (Id.t located * bool * inductive * glob_sort) list -> unit
+ (Id.t located * bool * inductive * Sorts.family) list -> unit
(** Main calls to interpret the Scheme command *)
diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml
index 645320c603..dbf7fec660 100644
--- a/vernac/lemmas.ml
+++ b/vernac/lemmas.ml
@@ -11,7 +11,6 @@
open CErrors
open Util
-open Flags
open Pp
open Names
open Term
@@ -49,7 +48,7 @@ let retrieve_first_recthm uctx = function
(NamedDecl.get_value (Global.lookup_named id),variable_opacity id)
| ConstRef cst ->
let cb = Global.lookup_constant cst in
- let (_, uctx) = UState.universe_context uctx in
+ let (_, uctx) = UState.universe_context ~names:[] ~extensible:true uctx in
let inst = Univ.UContext.instance uctx in
let map (c, ctx) = Vars.subst_instance_constr inst c in
(Option.map map (Global.body_of_constant_body cb), is_opaque cb)
@@ -61,7 +60,7 @@ let adjust_guardness_conditions const = function
(* Try all combinations... not optimal *)
let env = Global.env() in
{ const with const_entry_body =
- Future.chain ~pure:true const.const_entry_body
+ Future.chain const.const_entry_body
(fun ((body, ctx), eff) ->
match kind_of_term body with
| Fix ((nv,0),(_,_,fixdefs as fixdecls)) ->
@@ -137,7 +136,7 @@ let find_mutually_recursive_statements thms =
assert (List.is_empty rest);
(* One occ. of common coind ccls and no common inductive hyps *)
if not (List.is_empty common_same_indhyp) then
- if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements.");
+ Flags.if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements.");
flush_all ();
indccl, true, []
| [], _::_ ->
@@ -145,7 +144,7 @@ let find_mutually_recursive_statements thms =
| ind :: _ ->
if List.distinct_f ind_ord (List.map pi1 ind)
then
- if_verbose Feedback.msg_info
+ Flags.if_verbose Feedback.msg_info
(strbrk
("Coinductive statements do not follow the order of "^
"definition, assuming the proof to be by induction."));
@@ -181,10 +180,14 @@ let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook =
try
let const = adjust_guardness_conditions const do_guard in
let k = Kindops.logical_kind_of_goal_kind kind in
+ let should_suggest = const.const_entry_opaque && Option.is_empty const.const_entry_secctx in
let l,r = match locality with
| Discharge when Lib.sections_are_opened () ->
let c = SectionLocalDef const in
let _ = declare_variable id (Lib.cwd(), c, k) in
+ let () = if should_suggest
+ then Proof_using.suggest_variable (Global.env ()) id
+ in
(Local, VarRef id)
| Local | Global | Discharge ->
let local = match locality with
@@ -193,7 +196,11 @@ let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook =
in
let kn =
declare_constant ?export_seff id ~local (DefinitionEntry const, k) in
- (locality, ConstRef kn) in
+ let () = if should_suggest
+ then Proof_using.suggest_constant (Global.env ()) kn
+ in
+ (locality, ConstRef kn)
+ in
definition_message id;
Option.iter (Universes.register_universe_binders r) pl;
call_hook (fun exn -> exn) hook l r
@@ -210,11 +217,12 @@ let compute_proof_name locality = function
locality == Global && Nametab.exists_cci (Lib.make_path_except_section id)
then
user_err ?loc (pr_id id ++ str " already exists.");
- id, pl
+ id
| None ->
- next_global_ident_away default_thm_id (Proof_global.get_all_proof_names ()), None
+ let avoid = Id.Set.of_list (Proof_global.get_all_proof_names ()) in
+ next_global_ident_away default_thm_id avoid
-let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,(_,imps))) =
+let save_remaining_recthms (locality,p,kind) norm ctx binders body opaq i (id,(t_i,(_,imps))) =
let t_i = norm t_i in
match body with
| None ->
@@ -222,7 +230,7 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,
| Discharge ->
let impl = false in (* copy values from Vernacentries *)
let k = IsAssumption Conjectural in
- let c = SectionLocalAssum ((t_i,ctx),p,impl) in
+ let c = SectionLocalAssum ((t_i,Univ.ContextSet.of_context ctx),p,impl) in
let _ = declare_variable id (Lib.cwd(),c,k) in
(Discharge, VarRef id,imps)
| Local | Global ->
@@ -232,7 +240,6 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,
| Global -> false
| Discharge -> assert false
in
- let ctx = Univ.ContextSet.to_context ctx in
let decl = (ParameterEntry (None,p,(t_i,ctx),None), k) in
let kn = declare_constant id ~local decl in
(locality,ConstRef kn,imps))
@@ -250,12 +257,11 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,
match locality with
| Discharge ->
let const = definition_entry ~types:t_i ~opaque:opaq ~poly:p
- ~univs:(Univ.ContextSet.to_context ctx) body_i in
+ ~univs:ctx body_i in
let c = SectionLocalDef const in
let _ = declare_variable id (Lib.cwd(), c, k) in
(Discharge,VarRef id,imps)
| Local | Global ->
- let ctx = Univ.ContextSet.to_context ctx in
let local = match locality with
| Local -> true
| Global -> false
@@ -312,12 +318,6 @@ let get_proof proof do_guard hook opacity =
in
id,{const with const_entry_opaque = opacity},univs,do_guard,persistence,hook
-let check_exist =
- List.iter (fun (loc,id) ->
- if not (Nametab.exists_cci (Lib.make_path id)) then
- user_err ?loc (pr_id id ++ str " does not exist.")
- )
-
let universe_proof_terminator compute_guard hook =
let open Proof_global in
make_terminator begin function
@@ -325,17 +325,16 @@ let universe_proof_terminator compute_guard hook =
admit (id,k,pe) pl (hook (Some ctx)) ();
Feedback.feedback Feedback.AddedAxiom
| Proved (opaque,idopt,proof) ->
- let is_opaque, export_seff, exports = match opaque with
- | Vernacexpr.Transparent -> false, true, []
- | Vernacexpr.Opaque None -> true, false, []
- | Vernacexpr.Opaque (Some l) -> true, true, l in
+ let is_opaque, export_seff = match opaque with
+ | Vernacexpr.Transparent -> false, true
+ | Vernacexpr.Opaque -> true, false
+ in
let proof = get_proof proof compute_guard
(hook (Some (fst proof.Proof_global.universes))) is_opaque in
begin match idopt with
| None -> save_named ~export_seff proof
| Some (_,id) -> save_anonymous ~export_seff proof id
- end;
- check_exist exports
+ end
end
let standard_proof_terminator compute_guard hook =
@@ -369,7 +368,7 @@ let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_
let rec_tac_initializer finite guard thms snl =
if finite then
- match List.map (fun ((id,_),(t,_)) -> (id,EConstr.of_constr t)) thms with
+ match List.map (fun (id,(t,_)) -> (id,EConstr.of_constr t)) thms with
| (id,_)::l -> Tactics.mutual_cofix id l 0
| _ -> assert false
else
@@ -377,11 +376,11 @@ let rec_tac_initializer finite guard thms snl =
let nl = match snl with
| None -> List.map succ (List.map List.last guard)
| Some nl -> nl
- in match List.map2 (fun ((id,_),(t,_)) n -> (id,n, EConstr.of_constr t)) thms nl with
+ in match List.map2 (fun (id,(t,_)) n -> (id,n, EConstr.of_constr t)) thms nl with
| (id,n,_)::l -> Tactics.mutual_fix id n l 0
| _ -> assert false
-let start_proof_with_initialization kind ctx recguard thms snl hook =
+let start_proof_with_initialization kind ctx decl recguard thms snl hook =
let intro_tac (_, (_, (ids, _))) =
Tacticals.New.tclMAP (function
| Name id -> Tactics.intro_mustbe_force id
@@ -406,7 +405,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook =
(if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in
match thms with
| [] -> anomaly (Pp.str "No proof to start.")
- | ((id,pl),(t,(_,imps)))::other_thms ->
+ | (id,(t,(_,imps)))::other_thms ->
let hook ctx strength ref =
let ctx = match ctx with
| None -> Evd.empty_evar_universe_context
@@ -418,22 +417,24 @@ let start_proof_with_initialization kind ctx recguard thms snl hook =
let body,opaq = retrieve_first_recthm ctx ref in
let subst = Evd.evar_universe_context_subst ctx in
let norm c = Universes.subst_opt_univs_constr subst c in
- let ctx = UState.context_set (*FIXME*) ctx in
+ let binders, ctx = Evd.check_univ_decl (Evd.from_ctx ctx) decl in
let body = Option.map norm body in
- List.map_i (save_remaining_recthms kind norm ctx body opaq) 1 other_thms in
+ List.map_i (save_remaining_recthms kind norm ctx binders body opaq) 1 other_thms in
let thms_data = (strength,ref,imps)::other_thms_data in
List.iter (fun (strength,ref,imps) ->
maybe_declare_manual_implicits false ref imps;
call_hook (fun exn -> exn) hook strength ref) thms_data in
- start_proof_univs id ?pl kind ctx (EConstr.of_constr t) ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard
+ start_proof_univs id ~pl:decl kind ctx (EConstr.of_constr t) ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard
let start_proof_com ?inference_hook kind thms hook =
let env0 = Global.env () in
- let levels = Option.map snd (fst (List.hd thms)) in
- let evdref = ref (match levels with
- | None -> Evd.from_env env0
- | Some l -> Evd.from_ctx (Evd.make_evar_universe_context env0 l))
- in
+ let decl = fst (List.hd thms) in
+ let evd, decl =
+ match decl with
+ | None -> Evd.from_env env0, Univdecls.default_univ_decl
+ | Some decl ->
+ Univdecls.interp_univ_decl_opt env0 (snd decl) in
+ let evdref = ref evd in
let thms = List.map (fun (sopt,(bl,t)) ->
let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in
let t', imps' = interp_type_evars_impls ~impls env evdref t in
@@ -449,16 +450,16 @@ let start_proof_com ?inference_hook kind thms hook =
let evd, nf = Evarutil.nf_evars_and_universes !evdref in
let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in
let () =
- match levels with
- | None -> ()
- | Some l -> ignore (Evd.universe_context evd ?names:l)
+ if not decl.Misctypes.univdecl_extensible_instance then
+ ignore (Evd.universe_context evd ~names:decl.Misctypes.univdecl_instance ~extensible:false)
+ else ()
in
let evd =
if pi2 kind then evd
else (* We fix the variables to ensure they won't be lowered to Set *)
Evd.fix_undefined_variables evd
in
- start_proof_with_initialization kind evd recguard thms snl hook
+ start_proof_with_initialization kind evd decl recguard thms snl hook
(* Saving a proof *)
@@ -505,13 +506,15 @@ let save_proof ?proof = function
let env = Global.env () in
let ids_typ = Environ.global_vars_set env typ in
let ids_def = Environ.global_vars_set env pproof in
- Some (Environ.keep_hyps env (Idset.union ids_typ ids_def))
+ Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def))
| _ -> None in
- let names = Proof_global.get_universe_binders () in
+ let decl = Proof_global.get_universe_decl () in
let evd = Evd.from_ctx universes in
- let binders, ctx = Evd.universe_context ?names evd in
- Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None),
- (universes, Some binders))
+ let binders, ctx = Evd.check_univ_decl evd decl in
+ let poly = pi2 k in
+ let binders = if poly then Some binders else None in
+ Admitted(id,k,(sec_vars, poly, (typ, ctx), None),
+ (universes, binders))
in
Proof_global.apply_terminator (Proof_global.get_terminator ()) pe
| Vernacexpr.Proved (is_opaque,idopt) ->
diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli
index a8c09c0fed..1e23c7314b 100644
--- a/vernac/lemmas.mli
+++ b/vernac/lemmas.mli
@@ -20,13 +20,13 @@ val call_hook :
(** A hook start_proof calls on the type of the definition being started *)
val set_start_hook : (EConstr.types -> unit) -> unit
-val start_proof : Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map ->
+val start_proof : Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map ->
?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) ->
?sign:Environ.named_context_val -> EConstr.types ->
?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards ->
unit declaration_hook -> unit
-val start_proof_univs : Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map ->
+val start_proof_univs : Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map ->
?terminator:(Proof_global.lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) ->
?sign:Environ.named_context_val -> EConstr.types ->
?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards ->
@@ -38,9 +38,9 @@ val start_proof_com :
unit declaration_hook -> unit
val start_proof_with_initialization :
- goal_kind -> Evd.evar_map ->
+ goal_kind -> Evd.evar_map -> Univdecls.universe_decl ->
(bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option ->
- ((Id.t (* name of thm *) * Proof_global.universe_binders option) *
+ (Id.t (* name of thm *) *
(types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list
-> int list option -> unit declaration_hook -> unit
diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml
index c0974d0a7c..9376afa8cc 100644
--- a/vernac/metasyntax.ml
+++ b/vernac/metasyntax.ml
@@ -7,7 +7,6 @@
(************************************************************************)
open Pp
-open Flags
open CErrors
open Util
open Names
@@ -98,102 +97,104 @@ let pr_grammar = function
quote (except a single quote alone) must be quoted) *)
let parse_format ((loc, str) : lstring) =
- let str = " "^str in
- let l = String.length str in
- let push_token a = function
- | cur::l -> (a::cur)::l
- | [] -> [[a]] in
- let push_white n l =
- if Int.equal n 0 then l else push_token (UnpTerminal (String.make n ' ')) l in
- let close_box i b = function
- | a::(_::_ as l) -> push_token (UnpBox (b,a)) l
- | _ -> user_err Pp.(str "Non terminated box in format.") in
- let close_quotation i =
- if i < String.length str && str.[i] == '\'' && (Int.equal (i+1) l || str.[i+1] == ' ')
- then i+1
- else user_err Pp.(str "Incorrectly terminated quoted expression.") in
+ let len = String.length str in
+ (* TODO: update the line of the location when the string contains newlines *)
+ let make_loc i j = Option.map (Loc.shift_loc (i+1) (j-len)) loc in
+ let push_token loc a = function
+ | (i,cur)::l -> (i,(loc,a)::cur)::l
+ | [] -> assert false in
+ let push_white i n l =
+ if Int.equal n 0 then l else push_token (make_loc i (i+n)) (UnpTerminal (String.make n ' ')) l in
+ let close_box start stop b = function
+ | (_,a)::(_::_ as l) -> push_token (make_loc start stop) (UnpBox (b,a)) l
+ | [a] -> user_err ?loc:(make_loc start stop) Pp.(str "Non terminated box in format.")
+ | [] -> assert false in
+ let close_quotation start i =
+ if i < len && str.[i] == '\'' then
+ if (Int.equal (i+1) len || str.[i+1] == ' ')
+ then i+1
+ else user_err ?loc:(make_loc (i+1) (i+1)) Pp.(str "Space expected after quoted expression.")
+ else
+ user_err ?loc:(make_loc start (i-1)) Pp.(str "Beginning of quoted expression expected to be ended by a quote.") in
let rec spaces n i =
- if i < String.length str && str.[i] == ' ' then spaces (n+1) (i+1)
+ if i < len && str.[i] == ' ' then spaces (n+1) (i+1)
else n in
let rec nonspaces quoted n i =
- if i < String.length str && str.[i] != ' ' then
+ if i < len && str.[i] != ' ' then
if str.[i] == '\'' && quoted &&
- (i+1 >= String.length str || str.[i+1] == ' ')
- then if Int.equal n 0 then user_err Pp.(str "Empty quoted token.") else n
+ (i+1 >= len || str.[i+1] == ' ')
+ then if Int.equal n 0 then user_err ?loc:(make_loc (i-1) i) Pp.(str "Empty quoted token.") else n
else nonspaces quoted (n+1) (i+1)
else
- if quoted then user_err Pp.(str "Spaces are not allowed in (quoted) symbols.")
+ if quoted then user_err ?loc:(make_loc i i) Pp.(str "Spaces are not allowed in (quoted) symbols.")
else n in
let rec parse_non_format i =
let n = nonspaces false 0 i in
- push_token (UnpTerminal (String.sub str i n)) (parse_token (i+n))
+ push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str i n)) (parse_token 1 (i+n))
and parse_quoted n i =
- if i < String.length str then match str.[i] with
+ if i < len then match str.[i] with
(* Parse " // " *)
- | '/' when i <= String.length str && str.[i+1] == '/' ->
- (* We forget the useless n spaces... *)
- push_token (UnpCut PpFnl)
- (parse_token (close_quotation (i+2)))
+ | '/' when i+1 < len && str.[i+1] == '/' ->
+ (* We discard the useless n spaces... *)
+ push_token (make_loc (i-n) (i+1)) (UnpCut PpFnl)
+ (parse_token 1 (close_quotation i (i+2)))
(* Parse " .. / .. " *)
- | '/' when i <= String.length str ->
+ | '/' when i+1 < len ->
let p = spaces 0 (i+1) in
- push_token (UnpCut (PpBrk (n,p)))
- (parse_token (close_quotation (i+p+1)))
+ push_token (make_loc (i-n) (i+p)) (UnpCut (PpBrk (n,p)))
+ (parse_token 1 (close_quotation i (i+p+1)))
| c ->
(* The spaces are real spaces *)
- push_white n (match c with
+ push_white i n (match c with
| '[' ->
- if i <= String.length str then match str.[i+1] with
+ if i+1 < len then match str.[i+1] with
(* Parse " [h .. ", *)
- | 'h' when i+1 <= String.length str && str.[i+2] == 'v' ->
- (parse_box (fun n -> PpHVB n) (i+3))
+ | 'h' when i+1 <= len && str.[i+2] == 'v' ->
+ (parse_box i (fun n -> PpHVB n) (i+3))
(* Parse " [v .. ", *)
| 'v' ->
- parse_box (fun n -> PpVB n) (i+2)
+ parse_box i (fun n -> PpVB n) (i+2)
(* Parse " [ .. ", *)
| ' ' | '\'' ->
- parse_box (fun n -> PpHOVB n) (i+1)
- | _ -> user_err Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.")
- else user_err Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.")
+ parse_box i (fun n -> PpHOVB n) (i+1)
+ | _ -> user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.")
+ else user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.")
(* Parse "]" *)
| ']' ->
- ([] :: parse_token (close_quotation (i+1)))
+ ((i,[]) :: parse_token 1 (close_quotation i (i+1)))
(* Parse a non formatting token *)
| c ->
let n = nonspaces true 0 i in
- push_token (UnpTerminal (String.sub str (i-1) (n+2)))
- (parse_token (close_quotation (i+n))))
+ push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str (i-1) (n+2)))
+ (parse_token 1 (close_quotation i (i+n))))
else
if Int.equal n 0 then []
- else user_err Pp.(str "Ending spaces non part of a format annotation.")
- and parse_box box i =
+ else user_err ?loc:(make_loc (len-n) len) Pp.(str "Ending spaces non part of a format annotation.")
+ and parse_box start box i =
let n = spaces 0 i in
- close_box i (box n) (parse_token (close_quotation (i+n)))
- and parse_token i =
+ close_box start (i+n-1) (box n) (parse_token 1 (close_quotation i (i+n)))
+ and parse_token k i =
let n = spaces 0 i in
let i = i+n in
- if i < l then match str.[i] with
+ if i < len then match str.[i] with
(* Parse a ' *)
- | '\'' when i+1 >= String.length str || str.[i+1] == ' ' ->
- push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1)))
+ | '\'' when i+1 >= len || str.[i+1] == ' ' ->
+ push_white (i-n) (n-k) (push_token (make_loc i (i+1)) (UnpTerminal "'") (parse_token 1 (i+1)))
(* Parse the beginning of a quoted expression *)
| '\'' ->
- parse_quoted (n-1) (i+1)
+ parse_quoted (n-k) (i+1)
(* Otherwise *)
| _ ->
- push_white (n-1) (parse_non_format i)
- else push_white n [[]]
+ push_white (i-n) (n-k) (parse_non_format i)
+ else push_white (i-n) n [(len,[])]
in
- try
- if not (String.is_empty str) then match parse_token 0 with
- | [l] -> l
- | _ -> user_err Pp.(str "Box closed without being opened in format.")
- else
- user_err Pp.(str "Empty format.")
- with reraise ->
- let (e, info) = CErrors.push reraise in
- let info = Option.cata (Loc.add_loc info) info loc in
- iraise (e, info)
+ if not (String.is_empty str) then
+ match parse_token 0 0 with
+ | [_,l] -> l
+ | (i,_)::_ -> user_err ?loc:(make_loc i i) Pp.(str "Box closed without being opened.")
+ | [] -> assert false
+ else
+ []
(***********************)
(* Analyzing notations *)
@@ -384,11 +385,11 @@ let is_next_terminal = function Terminal _ :: _ -> true | _ -> false
let is_next_break = function Break _ :: _ -> true | _ -> false
-let add_break n l = UnpCut (PpBrk(n,0)) :: l
+let add_break n l = (None,UnpCut (PpBrk(n,0))) :: l
let add_break_if_none n = function
- | ((UnpCut (PpBrk _) :: _) | []) as l -> l
- | l -> UnpCut (PpBrk(n,0)) :: l
+ | (((_,UnpCut (PpBrk _)) :: _) | []) as l -> l
+ | l -> (None,UnpCut (PpBrk(n,0))) :: l
let check_open_binder isopen sl m =
let pr_token = function
@@ -414,30 +415,30 @@ let make_hunks etyps symbols from =
let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
let u = UnpMetaVar (i,prec) in
if is_next_non_terminal prods then
- u :: add_break_if_none 1 (make prods)
+ (None,u) :: add_break_if_none 1 (make prods)
else
- u :: make_with_space prods
+ (None,u) :: make_with_space prods
| Terminal s :: prods when List.exists is_non_terminal prods ->
if (is_comma s || is_operator s) then
(* Always a breakable space after comma or separator *)
- UnpTerminal s :: add_break_if_none 1 (make prods)
+ (None,UnpTerminal s) :: add_break_if_none 1 (make prods)
else if is_right_bracket s && is_next_terminal prods then
(* Always no space after right bracked, but possibly a break *)
- UnpTerminal s :: add_break_if_none 0 (make prods)
+ (None,UnpTerminal s) :: add_break_if_none 0 (make prods)
else if is_left_bracket s && is_next_non_terminal prods then
- UnpTerminal s :: make prods
+ (None,UnpTerminal s) :: make prods
else if not (is_next_break prods) then
(* Add rigid space, no break, unless user asked for something *)
- UnpTerminal (s^" ") :: make prods
+ (None,UnpTerminal (s^" ")) :: make prods
else
(* Rely on user spaces *)
- UnpTerminal s :: make prods
+ (None,UnpTerminal s) :: make prods
| Terminal s :: prods ->
(* Separate but do not cut a trailing sequence of terminal *)
(match prods with
- | Terminal _ :: _ -> UnpTerminal (s^" ") :: make prods
- | _ -> UnpTerminal s :: make prods)
+ | Terminal _ :: _ -> (None,UnpTerminal (s^" ")) :: make prods
+ | _ -> (None,UnpTerminal s) :: make prods)
| Break n :: prods ->
add_break n (make prods)
@@ -452,12 +453,12 @@ let make_hunks etyps symbols from =
(* We add NonTerminal for simulation but remove it afterwards *)
else snd (List.sep_last (make (sl@[NonTerminal m]))) in
let hunk = match typ with
- | ETConstr _ -> UnpListMetaVar (i,prec,sl')
+ | ETConstr _ -> UnpListMetaVar (i,prec,List.map snd sl')
| ETBinder isopen ->
check_open_binder isopen sl m;
- UnpBinderListMetaVar (i,isopen,sl')
+ UnpBinderListMetaVar (i,isopen,List.map snd sl')
| _ -> assert false in
- hunk :: make_with_space prods
+ (None,hunk) :: make_with_space prods
| [] -> []
@@ -466,7 +467,7 @@ let make_hunks etyps symbols from =
| Terminal s' :: prods'->
if is_operator s' then
(* A rigid space before operator and a breakable after *)
- UnpTerminal (" "^s') :: add_break_if_none 1 (make prods')
+ (None,UnpTerminal (" "^s')) :: add_break_if_none 1 (make prods')
else if is_comma s' then
(* No space whatsoever before comma *)
make prods
@@ -487,82 +488,63 @@ let make_hunks etyps symbols from =
(* Build default printing rules from explicit format *)
-let error_format () = user_err Pp.(str "The format does not match the notation.")
+let error_format ?loc () = user_err ?loc Pp.(str "The format does not match the notation.")
let rec split_format_at_ldots hd = function
- | UnpTerminal s :: fmt when String.equal s (Id.to_string ldots_var) -> List.rev hd, fmt
+ | (loc,UnpTerminal s) :: fmt when String.equal s (Id.to_string ldots_var) -> loc, List.rev hd, fmt
| u :: fmt ->
check_no_ldots_in_box u;
split_format_at_ldots (u::hd) fmt
| [] -> raise Exit
and check_no_ldots_in_box = function
- | UnpBox (_,fmt) ->
+ | (_,UnpBox (_,fmt)) ->
(try
- let _ = split_format_at_ldots [] fmt in
- user_err Pp.(str ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse."))
+ let loc,_,_ = split_format_at_ldots [] fmt in
+ user_err ?loc Pp.(str ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse."))
with Exit -> ())
| _ -> ()
+let error_not_same ?loc () =
+ user_err ?loc Pp.(str "The format is not the same on the right- and left-hand sides of the special token \"..\".")
+
let skip_var_in_recursive_format = function
- | UnpTerminal _ :: sl (* skip first var *) ->
+ | (_,UnpTerminal s) :: sl (* skip first var *) when not (List.for_all (fun c -> c = " ") (String.explode s)) ->
(* To do, though not so important: check that the names match
the names in the notation *)
sl
- | _ -> error_format ()
+ | (loc,_) :: _ -> error_not_same ?loc ()
+ | [] -> assert false
let read_recursive_format sl fmt =
let get_head fmt =
let sl = skip_var_in_recursive_format fmt in
- try split_format_at_ldots [] sl with Exit -> error_format () in
+ try split_format_at_ldots [] sl with Exit -> error_not_same ?loc:(fst (List.last (if sl = [] then fmt else sl))) () in
let rec get_tail = function
- | a :: sepfmt, b :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *)
+ | (loc,a) :: sepfmt, (_,b) :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *)
| [], tail -> skip_var_in_recursive_format tail
- | _ -> user_err Pp.(str "The format is not the same on the right and left hand side of the special token \"..\".") in
- let slfmt, fmt = get_head fmt in
+ | (loc,_) :: _, ([] | (_,UnpTerminal _) :: _)-> error_not_same ?loc ()
+ | _, (loc,_)::_ -> error_not_same ?loc () in
+ let loc, slfmt, fmt = get_head fmt in
slfmt, get_tail (slfmt, fmt)
-let warn_skip_spaces_curly =
- CWarnings.create ~name:"skip-spaces-curly" ~category:"parsing"
- (fun () ->strbrk "Skipping spaces inside curly brackets")
-
-let rec drop_spacing = function
- | UnpCut _ :: fmt -> warn_skip_spaces_curly (); drop_spacing fmt
- | UnpTerminal s' :: fmt when String.equal s' (String.make (String.length s') ' ') -> warn_skip_spaces_curly (); drop_spacing fmt
- | fmt -> fmt
-
-let has_closing_curly_brace symbs fmt =
- (* TODO: recognize and fail in case a box overlaps a pair of curly braces *)
- let fmt = drop_spacing fmt in
- match symbs, fmt with
- | NonTerminal s :: symbs, (UnpTerminal s' as u) :: fmt when Id.equal s (Id.of_string s') ->
- let fmt = drop_spacing fmt in
- (match fmt with
- | UnpTerminal "}" :: fmt -> Some (u :: fmt)
- | _ -> None)
- | _ -> None
-
let hunks_of_format (from,(vars,typs)) symfmt =
- let a = ref None in
let rec aux = function
- | symbs, (UnpTerminal s' as u) :: fmt
+ | symbs, (_,(UnpTerminal s' as u)) :: fmt
when String.equal s' (String.make (String.length s') ' ') ->
let symbs, l = aux (symbs,fmt) in symbs, u :: l
- | symbs, (UnpTerminal "{") :: fmt when (a := has_closing_curly_brace symbs fmt; !a <> None) ->
- let newfmt = Option.get !a in
- aux (symbs,newfmt)
- | Terminal s :: symbs, (UnpTerminal s') :: fmt
+ | Terminal s :: symbs, (_,UnpTerminal s') :: fmt
when String.equal s (String.drop_simple_quotes s') ->
let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l
- | NonTerminal s :: symbs, UnpTerminal s' :: fmt when Id.equal s (Id.of_string s') ->
+ | NonTerminal s :: symbs, (_,UnpTerminal s') :: fmt when Id.equal s (Id.of_string s') ->
let i = index_id s vars in
let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l
- | symbs, UnpBox (a,b) :: fmt ->
+ | symbs, (_,UnpBox (a,b)) :: fmt ->
let symbs', b' = aux (symbs,b) in
let symbs', l = aux (symbs',fmt) in
- symbs', UnpBox (a,b') :: l
- | symbs, (UnpCut _ as u) :: fmt ->
+ symbs', UnpBox (a,List.map (fun x -> (None,x)) b') :: l
+ | symbs, (_,(UnpCut _ as u)) :: fmt ->
let symbs, l = aux (symbs,fmt) in symbs, u :: l
| SProdList (m,sl) :: symbs, fmt ->
let i = index_id m vars in
@@ -570,7 +552,7 @@ let hunks_of_format (from,(vars,typs)) symfmt =
let _,prec = precedence_of_entry_type from typ in
let slfmt,fmt = read_recursive_format sl fmt in
let sl, slfmt = aux (sl,slfmt) in
- if not (List.is_empty sl) then error_format ();
+ if not (List.is_empty sl) then error_format ?loc:(fst (List.last fmt)) ();
let symbs, l = aux (symbs,fmt) in
let hunk = match typ with
| ETConstr _ -> UnpListMetaVar (i,prec,slfmt)
@@ -580,7 +562,7 @@ let hunks_of_format (from,(vars,typs)) symfmt =
| _ -> assert false in
symbs, hunk :: l
| symbs, [] -> symbs, []
- | _, _ -> error_format ()
+ | _, fmt -> error_format ?loc:(fst (List.hd fmt)) ()
in
match aux symfmt with
| [], l -> l
@@ -705,26 +687,40 @@ let recompute_assoc typs =
(**************************************************************************)
(* Registration of syntax extensions (parsing/printing, no interpretation)*)
-let pr_arg_level from = function
+let pr_arg_level from (lev,typ) =
+ let pplev = match lev with
| (n,L) when Int.equal n from -> str "at next level"
| (n,E) -> str "at level " ++ int n
| (n,L) -> str "at level below " ++ int n
| (n,Prec m) when Int.equal m n -> str "at level " ++ int n
- | (n,_) -> str "Unknown level"
-
-let pr_level ntn (from,args) =
+ | (n,_) -> str "Unknown level" in
+ let pptyp = match typ with
+ | NtnInternTypeConstr -> mt ()
+ | NtnInternTypeBinder -> str " " ++ surround (str "binder")
+ | NtnInternTypeIdent -> str " " ++ surround (str "ident") in
+ pplev ++ pptyp
+
+let pr_level ntn (from,args,typs) =
str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++
- prlist_with_sep pr_comma (pr_arg_level from) args
+ prlist_with_sep pr_comma (pr_arg_level from) (List.combine args typs)
let error_incompatible_level ntn oldprec prec =
user_err
- (str "Notation " ++ str ntn ++ str " is already defined" ++ spc() ++
+ (str "Notation " ++ qstring ntn ++ str " is already defined" ++ spc() ++
+ pr_level ntn oldprec ++
+ spc() ++ str "while it is now required to be" ++ spc() ++
+ pr_level ntn prec ++ str ".")
+
+let error_parsing_incompatible_level ntn ntn' oldprec prec =
+ user_err
+ (str "Notation " ++ qstring ntn ++ str " relies on a parsing rule for " ++ qstring ntn' ++ spc() ++
+ str " which is already defined" ++ spc() ++
pr_level ntn oldprec ++
spc() ++ str "while it is now required to be" ++ spc() ++
pr_level ntn prec ++ str ".")
type syntax_extension = {
- synext_level : Notation.level;
+ synext_level : Notation_term.level;
synext_notation : notation;
synext_notgram : notation_grammar;
synext_unparsing : unparsing list;
@@ -736,7 +732,17 @@ let is_active_compat = function
| None -> true
| Some v -> 0 <= Flags.version_compare v !Flags.compat_version
-type syntax_extension_obj = locality_flag * syntax_extension list
+type syntax_extension_obj = locality_flag * syntax_extension
+
+let check_and_extend_constr_grammar ntn rule =
+ try
+ let ntn_for_grammar = rule.notgram_notation in
+ if String.equal ntn ntn_for_grammar then raise Not_found;
+ let prec = rule.notgram_level in
+ let oldprec = Notation.level_of_notation ntn_for_grammar in
+ if not (Notation.level_eq prec oldprec) then error_parsing_incompatible_level ntn ntn_for_grammar oldprec prec;
+ with Not_found ->
+ Egramcoq.extend_constr_grammar rule
let cache_one_syntax_extension se =
let ntn = se.synext_notation in
@@ -744,31 +750,30 @@ let cache_one_syntax_extension se =
let onlyprint = se.synext_notgram.notgram_onlyprinting in
try
let oldprec = Notation.level_of_notation ntn in
- if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec
+ if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec;
with Not_found ->
if is_active_compat se.synext_compat then begin
(* Reserve the notation level *)
Notation.declare_notation_level ntn prec;
(* Declare the parsing rule *)
- if not onlyprint then Egramcoq.extend_constr_grammar prec se.synext_notgram;
+ if not onlyprint then List.iter (check_and_extend_constr_grammar ntn) se.synext_notgram.notgram_rules;
(* Declare the notation rule *)
Notation.declare_notation_rule ntn
- ~extra:se.synext_extra (se.synext_unparsing, fst prec) se.synext_notgram
+ ~extra:se.synext_extra (se.synext_unparsing, pi1 prec) se.synext_notgram
end
let cache_syntax_extension (_, (_, sy)) =
- List.iter cache_one_syntax_extension sy
+ cache_one_syntax_extension sy
let subst_parsing_rule subst x = x
let subst_printing_rule subst x = x
let subst_syntax_extension (subst, (local, sy)) =
- let map sy = { sy with
- synext_notgram = subst_parsing_rule subst sy.synext_notgram;
+ (local, { sy with
+ synext_notgram = { sy.synext_notgram with notgram_rules = List.map (subst_parsing_rule subst) sy.synext_notgram.notgram_rules };
synext_unparsing = subst_printing_rule subst sy.synext_unparsing;
- } in
- (local, List.map map sy)
+ })
let classify_syntax_definition (local, _ as o) =
if local then Dispose else Substitute o
@@ -796,7 +801,7 @@ type notation_modifier = {
(* common to syn_data below *)
only_parsing : bool;
only_printing : bool;
- compat : compat_version option;
+ compat : Flags.compat_version option;
format : string Loc.located option;
extra : (string * string) list;
}
@@ -986,7 +991,7 @@ let is_not_printable onlyparse nonreversible = function
(warn_non_reversible_notation (); true)
else onlyparse
-let find_precedence lev etyps symbols =
+let find_precedence lev etyps symbols onlyprint =
let first_symbol =
let rec aux = function
| Break _ :: t -> aux t
@@ -1004,8 +1009,13 @@ let find_precedence lev etyps symbols =
| None -> [],0
| Some (NonTerminal x) ->
(try match List.assoc x etyps with
- | ETConstr _ ->
- user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.")
+ | ETConstr _ ->
+ if onlyprint then
+ if Option.is_empty lev then
+ user_err Pp.(str "Explicit level needed in only-printing mode when the level of the leftmost non-terminal is given.")
+ else [],Option.get lev
+ else
+ user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.")
| ETName | ETBigint | ETReference ->
begin match lev with
| None ->
@@ -1049,13 +1059,10 @@ let remove_curly_brackets l =
| Terminal "{" as t1 :: l ->
let br,next = skip_break [] l in
(match next with
- | NonTerminal _ as x :: l' as l0 ->
+ | NonTerminal _ as x :: l' ->
let br',next' = skip_break [] l' in
(match next' with
- | Terminal "}" as t2 :: l'' as l1 ->
- if not (List.equal Notation.symbol_eq l l0) ||
- not (List.equal Notation.symbol_eq l' l1) then
- warn_skip_spaces_curly ();
+ | Terminal "}" as t2 :: l'' ->
if deb && List.is_empty l'' then [t1;x;t2] else begin
check_curly_brackets_notation_exists ();
x :: aux false l''
@@ -1067,6 +1074,8 @@ let remove_curly_brackets l =
module SynData = struct
+ type subentry_types = (Id.t * (production_level, production_position) constr_entry_key_gen) list
+
(* XXX: Document *)
type syn_data = {
@@ -1076,7 +1085,7 @@ module SynData = struct
(* Fields coming from the vernac-level modifiers *)
only_parsing : bool;
only_printing : bool;
- compat : compat_version option;
+ compat : Flags.compat_version option;
format : string Loc.located option;
extra : (string * string) list;
@@ -1089,17 +1098,28 @@ module SynData = struct
intern_typs : notation_var_internalization_type list;
(* Notation data for parsing *)
-
- level : int;
- syntax_data : (Id.t * (production_level, production_position) constr_entry_key_gen) list * (* typs *)
- symbol list; (* symbols *)
+ level : level;
+ pa_syntax_data : subentry_types * symbol list;
+ pp_syntax_data : subentry_types * symbol list;
not_data : notation * (* notation *)
- (int * parenRelation) list * (* precedence *)
+ level * (* level, precedence, types *)
bool; (* needs_squash *)
}
end
+let find_subentry_types n assoc etyps symbols =
+ let innerlevel = NumLevel 200 in
+ let typs =
+ find_symbols
+ (NumLevel n,BorderProd(Left,assoc))
+ (innerlevel,InternalProd)
+ (NumLevel n,BorderProd(Right,assoc))
+ symbols in
+ let sy_typs = List.map (set_entry_type etyps) typs in
+ let prec = List.map (assoc_of_type n) sy_typs in
+ sy_typs, prec
+
let compute_syntax_data df modifiers =
let open SynData in
let open NotationMods in
@@ -1115,27 +1135,24 @@ let compute_syntax_data df modifiers =
(* Notations for interp and grammar *)
let ntn_for_interp = make_notation_key symbols in
- let symbols' = remove_curly_brackets symbols in
- let ntn_for_grammar = make_notation_key symbols' in
- if not onlyprint then check_rule_productivity symbols';
-
- (* Misc *)
- let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in
- let msgs,n = find_precedence mods.level mods.etyps symbols' in
- let innerlevel = NumLevel 200 in
- let typs =
- find_symbols
- (NumLevel n,BorderProd(Left,assoc))
- (innerlevel,InternalProd)
- (NumLevel n,BorderProd(Right,assoc))
- symbols' in
+ let symbols_for_grammar = remove_curly_brackets symbols in
+ let need_squash = not (List.equal Notation.symbol_eq symbols symbols_for_grammar) in
+ let ntn_for_grammar = if need_squash then make_notation_key symbols_for_grammar else ntn_for_interp in
+ if not onlyprint then check_rule_productivity symbols_for_grammar;
+ let msgs,n = find_precedence mods.level mods.etyps symbols onlyprint in
(* To globalize... *)
let etyps = join_auxiliary_recursive_types recvars mods.etyps in
- let sy_typs = List.map (set_entry_type etyps) typs in
- let prec = List.map (assoc_of_type n) sy_typs in
+ let sy_typs, prec =
+ find_subentry_types n assoc etyps symbols in
+ let sy_typs_for_grammar, prec_for_grammar =
+ if need_squash then
+ find_subentry_types n assoc etyps symbols_for_grammar
+ else
+ sy_typs, prec in
let i_typs = set_internalization_type sy_typs in
- let sy_data = (sy_typs,symbols') in
- let sy_fulldata = (ntn_for_grammar,prec,need_squash) in
+ let pa_sy_data = (sy_typs_for_grammar,symbols_for_grammar) in
+ let pp_sy_data = (sy_typs,symbols) in
+ let sy_fulldata = (ntn_for_grammar,(n,prec_for_grammar,i_typs),need_squash) in
let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in
let i_data = ntn_for_interp, df' in
@@ -1154,8 +1171,9 @@ let compute_syntax_data df modifiers =
mainvars;
intern_typs = i_typs;
- level = n;
- syntax_data = sy_data;
+ level = (n,prec,i_typs);
+ pa_syntax_data = pa_sy_data;
+ pp_syntax_data = pp_sy_data;
not_data = sy_fulldata;
}
@@ -1236,25 +1254,9 @@ let with_syntax_protection f x =
(**********************************************************************)
(* Recovering existing syntax *)
-let contract_notation ntn =
- if String.equal ntn "{ _ }" then ntn else
- let rec aux ntn i =
- if i <= String.length ntn - 5 then
- let ntn' =
- if String.is_sub "{ _ }" ntn i &&
- (i = 0 || ntn.[i-1] = ' ') &&
- (i = String.length ntn - 5 || ntn.[i+5] = ' ')
- then
- String.sub ntn 0 i ^ "_" ^
- String.sub ntn (i+5) (String.length ntn -i-5)
- else ntn in
- aux ntn' (i+1)
- else ntn in
- aux ntn 0
-
exception NoSyntaxRule
-let recover_syntax ntn =
+let recover_notation_syntax ntn =
try
let prec = Notation.level_of_notation ntn in
let pp_rule,_ = Notation.find_notation_printing_rule ntn in
@@ -1271,29 +1273,25 @@ let recover_syntax ntn =
raise NoSyntaxRule
let recover_squash_syntax sy =
- let sq = recover_syntax "{ _ }" in
- [sy; sq]
-
-let recover_notation_syntax rawntn =
- let ntn = contract_notation rawntn in
- let sy = recover_syntax ntn in
- let need_squash = not (String.equal ntn rawntn) in
- let rules = if need_squash then recover_squash_syntax sy else [sy] in
- sy.synext_notgram.notgram_typs, rules, sy.synext_notgram.notgram_onlyprinting
+ let sq = recover_notation_syntax "{ _ }" in
+ sy :: sq.synext_notgram.notgram_rules
(**********************************************************************)
(* Main entry point for building parsing and printing rules *)
-let make_pa_rule i_typs level (typs,symbols) ntn onlyprint =
+let make_pa_rule level (typs,symbols) ntn need_squash =
let assoc = recompute_assoc typs in
let prod = make_production typs symbols in
- { notgram_level = level;
+ let sy = {
+ notgram_level = level;
notgram_assoc = assoc;
notgram_notation = ntn;
notgram_prods = prod;
- notgram_typs = i_typs;
- notgram_onlyprinting = onlyprint;
- }
+ } in
+ (* By construction, the rule for "{ _ }" is declared, but we need to
+ redeclare it because the file where it is declared needs not be open
+ when the current file opens (especially in presence of -nois) *)
+ if need_squash then recover_squash_syntax sy else [sy]
let make_pp_rule level (typs,symbols) fmt =
match fmt with
@@ -1302,21 +1300,16 @@ let make_pp_rule level (typs,symbols) fmt =
(* let make_syntax_rules i_typs (ntn,prec,need_squash) sy_data fmt extra onlyprint compat = *)
let make_syntax_rules (sd : SynData.syn_data) = let open SynData in
- let ntn, prec, need_squash = sd.not_data in
- let pa_rule = make_pa_rule sd.intern_typs sd.level sd.syntax_data ntn sd.only_printing in
- let pp_rule = make_pp_rule sd.level sd.syntax_data sd.format in
- let sy = {
- synext_level = (sd.level, prec);
- synext_notation = ntn;
- synext_notgram = pa_rule;
+ let ntn_for_grammar, prec_for_grammar, need_squash = sd.not_data in
+ let pa_rule = make_pa_rule prec_for_grammar sd.pa_syntax_data ntn_for_grammar need_squash in
+ let pp_rule = make_pp_rule (pi1 sd.level) sd.pp_syntax_data sd.format in {
+ synext_level = sd.level;
+ synext_notation = fst sd.info;
+ synext_notgram = { notgram_onlyprinting = sd.only_printing; notgram_rules = pa_rule };
synext_unparsing = pp_rule;
synext_extra = sd.extra;
synext_compat = sd.compat;
- } in
- (* By construction, the rule for "{ _ }" is declared, but we need to
- redeclare it because the file where it is declared needs not be open
- when the current file opens (especially in presence of -nois) *)
- if need_squash then recover_squash_syntax sy else [sy]
+ }
(**********************************************************************)
(* Main functions about notations *)
@@ -1325,7 +1318,7 @@ let to_map l =
let fold accu (x, v) = Id.Map.add x v accu in
List.fold_left fold Id.Map.empty l
-let add_notation_in_scope local df c mods scope =
+let add_notation_in_scope local df env c mods scope =
let open SynData in
let sd = compute_syntax_data df mods in
(* Prepare the interpretation *)
@@ -1336,7 +1329,7 @@ let add_notation_in_scope local df c mods scope =
ninterp_var_type = to_map i_vars;
ninterp_rec_vars = to_map sd.recvars;
} in
- let (acvars, ac, reversible) = interp_notation_constr nenv c in
+ let (acvars, ac, reversible) = interp_notation_constr env nenv c in
let interp = make_interpretation_vars sd.recvars acvars in
let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in
let onlyparse = is_not_printable sd.only_parsing (not reversible) ac in
@@ -1356,16 +1349,16 @@ let add_notation_in_scope local df c mods scope =
Lib.add_anonymous_leaf (inNotation notation);
sd.info
-let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat =
+let add_notation_interpretation_core local df env ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat =
let dfs = split_notation_string df in
let (recvars,mainvars,symbs) = analyze_notation_tokens ~onlyprint dfs in
(* Recover types of variables and pa/pp rules; redeclare them if needed *)
let i_typs, onlyprint = if not (is_numeral symbs) then begin
- let i_typs,sy_rules,onlyprint' = recover_notation_syntax (make_notation_key symbs) in
- let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)) in
+ let sy = recover_notation_syntax (make_notation_key symbs) in
+ let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy)) in
(** If the only printing flag has been explicitly requested, put it back *)
- let onlyprint = onlyprint || onlyprint' in
- i_typs, onlyprint
+ let onlyprint = onlyprint || sy.synext_notgram.notgram_onlyprinting in
+ pi3 sy.synext_level, onlyprint
end else [], false in
(* Declare interpretation *)
let path = (Lib.library_dp(), Lib.current_dirpath true) in
@@ -1375,7 +1368,7 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env)
ninterp_var_type = to_map i_vars;
ninterp_rec_vars = to_map recvars;
} in
- let (acvars, ac, reversible) = interp_notation_constr ~impls nenv c in
+ let (acvars, ac, reversible) = interp_notation_constr env ~impls nenv c in
let interp = make_interpretation_vars recvars acvars in
let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in
let onlyparse = is_not_printable onlyparse (not reversible) ac in
@@ -1402,33 +1395,33 @@ let add_syntax_extension local ((loc,df),mods) = let open SynData in
(* Notations with only interpretation *)
-let add_notation_interpretation ((loc,df),c,sc) =
- let df' = add_notation_interpretation_core false df c sc false false None in
+let add_notation_interpretation env ((loc,df),c,sc) =
+ let df' = add_notation_interpretation_core false df env c sc false false None in
Dumpglob.dump_notation (loc,df') sc true
-let set_notation_for_interpretation impls ((_,df),c,sc) =
+let set_notation_for_interpretation env impls ((_,df),c,sc) =
(try ignore
- (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ());
+ (Flags.silently (fun () -> add_notation_interpretation_core false df env ~impls c sc false false None) ());
with NoSyntaxRule ->
user_err Pp.(str "Parsing rule for this notation has to be previously declared."));
Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc
(* Main entry point *)
-let add_notation local c ((loc,df),modifiers) sc =
+let add_notation local env c ((loc,df),modifiers) sc =
let df' =
if no_syntax_modifiers modifiers then
(* No syntax data: try to rely on a previously declared rule *)
let onlyparse = is_only_parsing modifiers in
let onlyprint = is_only_printing modifiers in
let compat = get_compat_version modifiers in
- try add_notation_interpretation_core local df c sc onlyparse onlyprint compat
+ try add_notation_interpretation_core local df env c sc onlyparse onlyprint compat
with NoSyntaxRule ->
(* Try to determine a default syntax rule *)
- add_notation_in_scope local df c modifiers sc
+ add_notation_in_scope local df env c modifiers sc
else
(* Declare both syntax and interpretation *)
- add_notation_in_scope local df c modifiers sc
+ add_notation_in_scope local df env c modifiers sc
in
Dumpglob.dump_notation (loc,df') sc true
@@ -1443,13 +1436,13 @@ let add_notation_extra_printing_rule df k v =
let inject_var x = CAst.make @@ CRef (Ident (Loc.tag @@ Id.of_string x),None)
-let add_infix local ((loc,inf),modifiers) pr sc =
+let add_infix local env ((loc,inf),modifiers) pr sc =
check_infix_modifiers modifiers;
(* check the precedence *)
let metas = [inject_var "x"; inject_var "y"] in
let c = mkAppC (pr,metas) in
let df = "x "^(quote_notation_token inf)^" y" in
- add_notation local c ((loc,df),modifiers) sc
+ add_notation local env c ((loc,df),modifiers) sc
(**********************************************************************)
(* Delimiters and classes bound to scopes *)
@@ -1505,7 +1498,7 @@ let try_interp_name_alias = function
| [], { CAst.v = CRef (ref,_) } -> intern_reference ref
| _ -> raise Not_found
-let add_syntactic_definition ident (vars,c) local onlyparse =
+let add_syntactic_definition env ident (vars,c) local onlyparse =
let nonprintable = ref false in
let vars,pat =
try [], NRef (try_interp_name_alias (vars,c))
@@ -1516,7 +1509,7 @@ let add_syntactic_definition ident (vars,c) local onlyparse =
ninterp_var_type = i_vars;
ninterp_rec_vars = Id.Map.empty;
} in
- let nvars, pat, reversible = interp_notation_constr nenv c in
+ let nvars, pat, reversible = interp_notation_constr env nenv c in
let () = nonprintable := not reversible in
let map id = let (_,sc,_) = Id.Map.find id nvars in (id, sc) in
List.map map vars, pat
diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli
index 9cd00cbcb4..b3049f1b7a 100644
--- a/vernac/metasyntax.mli
+++ b/vernac/metasyntax.mli
@@ -11,15 +11,16 @@ open Vernacexpr
open Notation
open Constrexpr
open Notation_term
+open Environ
val add_token_obj : string -> unit
(** Adding a (constr) notation in the environment*)
-val add_infix : locality_flag -> (lstring * syntax_modifier list) ->
+val add_infix : locality_flag -> env -> (lstring * syntax_modifier list) ->
constr_expr -> scope_name option -> unit
-val add_notation : locality_flag -> constr_expr ->
+val add_notation : locality_flag -> env -> constr_expr ->
(lstring * syntax_modifier list) -> scope_name option -> unit
val add_notation_extra_printing_rule : string -> string -> string -> unit
@@ -33,11 +34,11 @@ val add_class_scope : scope_name -> scope_class list -> unit
(** Add only the interpretation of a notation that already has pa/pp rules *)
val add_notation_interpretation :
- (lstring * constr_expr * scope_name option) -> unit
+ env -> (lstring * constr_expr * scope_name option) -> unit
(** Add a notation interpretation for supporting the "where" clause *)
-val set_notation_for_interpretation : Constrintern.internalization_env ->
+val set_notation_for_interpretation : env -> Constrintern.internalization_env ->
(lstring * constr_expr * scope_name option) -> unit
(** Add only the parsing/printing rule of a notation *)
@@ -47,7 +48,7 @@ val add_syntax_extension :
(** Add a syntactic definition (as in "Notation f := ...") *)
-val add_syntactic_definition : Id.t -> Id.t list * constr_expr ->
+val add_syntactic_definition : env -> Id.t -> Id.t list * constr_expr ->
bool -> Flags.compat_version option -> unit
(** Print the Camlp4 state of a grammar *)
diff --git a/vernac/mltop.ml b/vernac/mltop.ml
index e8a0ba3dda..d3de10235f 100644
--- a/vernac/mltop.ml
+++ b/vernac/mltop.ml
@@ -9,7 +9,6 @@
open CErrors
open Util
open Pp
-open Flags
open Libobject
open System
@@ -175,6 +174,7 @@ let warn_cannot_use_directory =
let convert_string d =
try Names.Id.of_string d
with UserError _ ->
+ let d = Unicode.escaped_if_non_utf8 d in
warn_cannot_use_directory d;
raise Exit
@@ -365,7 +365,7 @@ let trigger_ml_object verb cache reinit ?path name =
else begin
let file = file_of_name (Option.default name path) in
let path =
- if_verbose_load (verb && not !quiet) load_ml_object name ?path file in
+ if_verbose_load (verb && not !Flags.quiet) load_ml_object name ?path file in
add_loaded_module name (Some path);
if cache then perform_cache_obj name
end
diff --git a/vernac/obligations.ml b/vernac/obligations.ml
index a4fe49020a..785c842ba1 100644
--- a/vernac/obligations.ml
+++ b/vernac/obligations.ml
@@ -304,7 +304,7 @@ type program_info_aux = {
prg_body: constr;
prg_type: constr;
prg_ctx: Evd.evar_universe_context;
- prg_pl: Id.t Loc.located list option;
+ prg_univdecl: Univdecls.universe_decl;
prg_obligations: obligations;
prg_deps : Id.t list;
prg_fixkind : fixpoint_kind option ;
@@ -474,8 +474,7 @@ let declare_definition prg =
(Evd.evar_universe_context_subst prg.prg_ctx) in
let opaque = prg.prg_opaque in
let fix_exn = Hook.get get_fix_exn () in
- let pl, ctx =
- Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in
+ let pl, ctx = Evd.check_univ_decl (Evd.from_ctx prg.prg_ctx) prg.prg_univdecl in
let ce =
definition_entry ~fix_exn
~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind)
@@ -557,7 +556,7 @@ let declare_mutual_definition l =
let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) [] ctx)
fixnames fixdecls fixtypes fiximps in
(* Declare notations *)
- List.iter Metasyntax.add_notation_interpretation first.prg_notations;
+ List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations;
Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames;
let gr = List.hd kns in
let kn = match gr with ConstRef kn -> kn | _ -> assert false in
@@ -658,7 +657,7 @@ let declare_obligation prg obl body ty uctx =
else
Some (TermObl (it_mkLambda_or_LetIn_or_clean (mkApp (mkConst constant, args)) ctx)) }
-let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind
+let init_prog_info ?(opaque = false) sign n udecl b t ctx deps fixkind
notations obls impls kind reduce hook =
let obls', b =
match b with
@@ -679,7 +678,7 @@ let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind
obls, b
in
{ prg_name = n ; prg_body = b; prg_type = reduce t;
- prg_ctx = ctx; prg_pl = pl;
+ prg_ctx = ctx; prg_univdecl = udecl;
prg_obligations = (obls', Array.length obls');
prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
prg_implicits = impls; prg_kind = kind; prg_reduce = reduce;
@@ -847,9 +846,9 @@ let obligation_terminator name num guard hook auto pf =
let obl = obls.(num) in
let status =
match obl.obl_status, opq with
- | (_, Evar_kinds.Expand), Vernacexpr.Opaque _ -> err_not_transp ()
- | (true, _), Vernacexpr.Opaque _ -> err_not_transp ()
- | (false, _), Vernacexpr.Opaque _ -> Evar_kinds.Define true
+ | (_, Evar_kinds.Expand), Vernacexpr.Opaque -> err_not_transp ()
+ | (true, _), Vernacexpr.Opaque -> err_not_transp ()
+ | (false, _), Vernacexpr.Opaque -> Evar_kinds.Define true
| (_, Evar_kinds.Define true), Vernacexpr.Transparent -> Evar_kinds.Define false
| (_, status), Vernacexpr.Transparent -> status
in
@@ -889,7 +888,7 @@ in
let ctx' = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx')) in
Univ.Instance.empty, Evd.evar_universe_context ctx'
else
- let (_, uctx) = UState.universe_context ctx' in
+ let (_, uctx) = UState.universe_context ~names:[] ~extensible:true ctx' in
Univ.UContext.instance uctx, ctx'
in
let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in
@@ -1068,11 +1067,12 @@ let show_term n =
Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl ()
++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body)
-let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic
+let add_definition n ?term t ctx ?(univdecl=Univdecls.default_univ_decl)
+ ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic
?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls =
let sign = Decls.initialize_named_context_for_proof () in
let info = Id.print n ++ str " has type-checked" in
- let prg = init_prog_info sign ~opaque n pl term t ctx [] None [] obls implicits kind reduce hook in
+ let prg = init_prog_info sign ~opaque n univdecl term t ctx [] None [] obls implicits kind reduce hook in
let obls,_ = prg.prg_obligations in
if Int.equal (Array.length obls) 0 then (
Flags.if_verbose Feedback.msg_info (info ++ str ".");
@@ -1087,13 +1087,14 @@ let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definit
| Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
| _ -> res)
-let add_mutual_definitions l ctx ?pl ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce)
+let add_mutual_definitions l ctx ?(univdecl=Univdecls.default_univ_decl) ?tactic
+ ?(kind=Global,false,Definition) ?(reduce=reduce)
?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind =
let sign = Decls.initialize_named_context_for_proof () in
let deps = List.map (fun (n, b, t, imps, obls) -> n) l in
List.iter
(fun (n, b, t, imps, obls) ->
- let prg = init_prog_info sign ~opaque n pl (Some b) t ctx deps (Some fixkind)
+ let prg = init_prog_info sign ~opaque n univdecl (Some b) t ctx deps (Some fixkind)
notations obls imps kind reduce hook
in progmap_add n (CEphemeron.create prg)) l;
let _defined =
diff --git a/vernac/obligations.mli b/vernac/obligations.mli
index 5614403ba5..11c2553ae1 100644
--- a/vernac/obligations.mli
+++ b/vernac/obligations.mli
@@ -53,7 +53,7 @@ val default_tactic : unit Proofview.tactic ref
val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types ->
Evd.evar_universe_context ->
- ?pl:(Id.t Loc.located list) -> (* Universe binders *)
+ ?univdecl:Univdecls.universe_decl -> (* Universe binders and constraints *)
?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list ->
?kind:Decl_kinds.definition_kind ->
?tactic:unit Proofview.tactic ->
@@ -71,7 +71,7 @@ val add_mutual_definitions :
(Names.Id.t * Term.constr * Term.types *
(Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
Evd.evar_universe_context ->
- ?pl:(Id.t Loc.located list) -> (* Universe binders *)
+ ?univdecl:Univdecls.universe_decl -> (* Universe binders and constraints *)
?tactic:unit Proofview.tactic ->
?kind:Decl_kinds.definition_kind ->
?reduce:(Term.constr -> Term.constr) ->
diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml
new file mode 100644
index 0000000000..ffe99cfd81
--- /dev/null
+++ b/vernac/proof_using.ml
@@ -0,0 +1,190 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Names
+open Environ
+open Util
+open Vernacexpr
+open Context.Named.Declaration
+
+module NamedDecl = Context.Named.Declaration
+
+let known_names = Summary.ref [] ~name:"proofusing-nameset"
+
+let in_nameset =
+ let open Libobject in
+ declare_object { (default_object "proofusing-nameset") with
+ cache_function = (fun (_,x) -> known_names := x :: !known_names);
+ classify_function = (fun _ -> Dispose);
+ discharge_function = (fun _ -> None)
+ }
+
+let rec close_fwd e s =
+ let s' =
+ List.fold_left (fun s decl ->
+ let vb = match decl with
+ | LocalAssum _ -> Id.Set.empty
+ | LocalDef (_,b,_) -> global_vars_set e b
+ in
+ let vty = global_vars_set e (NamedDecl.get_type decl) in
+ let vbty = Id.Set.union vb vty in
+ if Id.Set.exists (fun v -> Id.Set.mem v s) vbty
+ then Id.Set.add (NamedDecl.get_id decl) (Id.Set.union s vbty) else s)
+ s (named_context e)
+ in
+ if Id.Set.equal s s' then s else close_fwd e s'
+
+let set_of_type env ty =
+ List.fold_left (fun acc ty ->
+ Id.Set.union (global_vars_set env ty) acc)
+ Id.Set.empty ty
+
+let full_set env =
+ List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty
+
+let rec process_expr env e ty =
+ let rec aux = function
+ | SsEmpty -> Id.Set.empty
+ | SsType -> set_of_type env ty
+ | SsSingl (_,id) -> set_of_id env id
+ | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2)
+ | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2)
+ | SsCompl e -> Id.Set.diff (full_set env) (aux e)
+ | SsFwdClose e -> close_fwd env (aux e)
+ in
+ aux e
+
+and set_of_id env id =
+ if Id.to_string id = "All" then
+ List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty
+ else if CList.mem_assoc_f Id.equal id !known_names then
+ process_expr env (CList.assoc_f Id.equal id !known_names) []
+ else Id.Set.singleton id
+
+let process_expr env e ty =
+ let v_ty = set_of_type env ty in
+ let s = Id.Set.union v_ty (process_expr env e ty) in
+ Id.Set.elements s
+
+let name_set id expr = Lib.add_anonymous_leaf (in_nameset (id,expr))
+
+let minimize_hyps env ids =
+ let rec aux ids =
+ let ids' =
+ Id.Set.fold (fun id alive ->
+ let impl_by_id =
+ Id.Set.remove id (really_needed env (Id.Set.singleton id)) in
+ if Id.Set.is_empty impl_by_id then alive
+ else Id.Set.diff alive impl_by_id)
+ ids ids in
+ if Id.Set.equal ids ids' then ids else aux ids'
+ in
+ aux ids
+
+let remove_ids_and_lets env s ids =
+ let not_ids id = not (Id.Set.mem id ids) in
+ let no_body id = named_body id env = None in
+ let deps id = really_needed env (Id.Set.singleton id) in
+ (Id.Set.filter (fun id ->
+ not_ids id &&
+ (no_body id ||
+ Id.Set.exists not_ids (Id.Set.filter no_body (deps id)))) s)
+
+let record_proof_using expr =
+ Aux_file.record_in_aux "suggest_proof_using" expr
+
+(* Variables in [skip] come from after the definition, so don't count
+ for "All". Used in the variable case since the env contains the
+ variable itself. *)
+let suggest_common env ppid used ids_typ skip =
+ let module S = Id.Set in
+ let open Pp in
+ let print x = Feedback.msg_debug x in
+ let pr_set parens s =
+ let wrap ppcmds =
+ if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")"
+ else ppcmds in
+ wrap (prlist_with_sep (fun _ -> str" ") Id.print (S.elements s)) in
+
+ let needed = minimize_hyps env (remove_ids_and_lets env used ids_typ) in
+ let all_needed = really_needed env needed in
+ let all = List.fold_left (fun all d -> S.add (NamedDecl.get_id d) all)
+ S.empty (named_context env)
+ in
+ let all = S.diff all skip in
+ let fwd_typ = close_fwd env ids_typ in
+ if !Flags.debug then begin
+ print (str "All " ++ pr_set false all);
+ print (str "Type " ++ pr_set false ids_typ);
+ print (str "needed " ++ pr_set false needed);
+ print (str "all_needed " ++ pr_set false all_needed);
+ print (str "Type* " ++ pr_set false fwd_typ);
+ end;
+ let valid_exprs = ref [] in
+ let valid e = valid_exprs := e :: !valid_exprs in
+ if S.is_empty needed then valid (str "Type");
+ if S.equal all_needed fwd_typ then valid (str "Type*");
+ if S.equal all all_needed then valid(str "All");
+ valid (pr_set false needed);
+ Feedback.msg_info (
+ str"The proof of "++ ppid ++ spc() ++
+ str "should start with one of the following commands:"++spc()++
+ v 0 (
+ prlist_with_sep cut (fun x->str"Proof using " ++x++ str". ") !valid_exprs));
+ if !Flags.record_aux_file
+ then
+ let s = string_of_ppcmds (prlist_with_sep (fun _ -> str";") (fun x->x) !valid_exprs) in
+ record_proof_using s
+
+let suggest_proof_using = ref false
+
+let _ =
+ Goptions.declare_bool_option
+ { Goptions.optdepr = false;
+ Goptions.optname = "suggest Proof using";
+ Goptions.optkey = ["Suggest";"Proof";"Using"];
+ Goptions.optread = (fun () -> !suggest_proof_using);
+ Goptions.optwrite = ((:=) suggest_proof_using) }
+
+let suggest_constant env kn =
+ if !suggest_proof_using
+ then begin
+ let open Declarations in
+ let body = lookup_constant kn env in
+ let used = Id.Set.of_list @@ List.map NamedDecl.get_id body.const_hyps in
+ let ids_typ = global_vars_set env body.const_type in
+ suggest_common env (Printer.pr_constant env kn) used ids_typ Id.Set.empty
+ end
+
+let suggest_variable env id =
+ if !suggest_proof_using
+ then begin
+ match lookup_named id env with
+ | LocalDef (_,body,typ) ->
+ let ids_typ = global_vars_set env typ in
+ let ids_body = global_vars_set env body in
+ let used = Id.Set.union ids_body ids_typ in
+ suggest_common env (Id.print id) used ids_typ (Id.Set.singleton id)
+ | LocalAssum _ -> assert false
+ end
+
+let value = ref None
+
+let using_to_string us = Pp.string_of_ppcmds (Ppvernac.pr_using us)
+let using_from_string us = Pcoq.Gram.(entry_parse G_vernac.section_subset_expr (parsable (Stream.of_string us)))
+
+let _ =
+ Goptions.declare_stringopt_option
+ { Goptions.optdepr = false;
+ Goptions.optname = "default value for Proof using";
+ Goptions.optkey = ["Default";"Proof";"Using"];
+ Goptions.optread = (fun () -> Option.map using_to_string !value);
+ Goptions.optwrite = (fun b -> value := Option.map using_from_string b);
+ }
+
+let get_default_proof_using () = !value
diff --git a/vernac/discharge.mli b/vernac/proof_using.mli
index c8c7e3b8b8..f63c8e2424 100644
--- a/vernac/discharge.mli
+++ b/vernac/proof_using.mli
@@ -6,9 +6,16 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Declarations
-open Entries
-open Opaqueproof
+(** Utility code for section variables handling in Proof using... *)
-val process_inductive :
- Lib.abstr_info -> work_list -> mutual_inductive_body -> mutual_inductive_entry
+val process_expr :
+ Environ.env -> Vernacexpr.section_subset_expr -> Constr.types list ->
+ Names.Id.t list
+
+val name_set : Names.Id.t -> Vernacexpr.section_subset_expr -> unit
+
+val suggest_constant : Environ.env -> Names.Constant.t -> unit
+
+val suggest_variable : Environ.env -> Names.Id.t -> unit
+
+val get_default_proof_using : unit -> Vernacexpr.section_subset_expr option
diff --git a/vernac/record.ml b/vernac/record.ml
index a2e443e5f7..5533fe5b38 100644
--- a/vernac/record.ml
+++ b/vernac/record.ml
@@ -72,7 +72,7 @@ let interp_fields_evars env evars impls_env nots l =
| None -> LocalAssum (i,t')
| Some b' -> LocalDef (i,b',t')
in
- List.iter (Metasyntax.set_notation_for_interpretation impls) no;
+ List.iter (Metasyntax.set_notation_for_interpretation env impls) no;
(EConstr.push_rel d env, impl :: uimpls, d::params, impls))
(env, [], [], impls_env) nots l
@@ -95,8 +95,8 @@ let binders_of_decls = List.map binder_of_decl
let typecheck_params_and_fields finite def id pl t ps nots fs =
let env0 = Global.env () in
- let ctx = Evd.make_evar_universe_context env0 pl in
- let evars = ref (Evd.from_ctx ctx) in
+ let evd, decl = Univdecls.interp_univ_decl_opt env0 pl in
+ let evars = ref evd in
let _ =
let error bk (loc, name) =
match bk, name with
@@ -165,9 +165,10 @@ let typecheck_params_and_fields finite def id pl t ps nots fs =
let newps = List.map (EConstr.to_rel_decl evars) newps in
let typ = EConstr.to_constr evars typ in
let ce t = Pretyping.check_evars env0 Evd.empty evars (EConstr.of_constr t) in
+ let univs = Evd.check_univ_decl evars decl in
List.iter (iter_constr ce) (List.rev newps);
List.iter (iter_constr ce) (List.rev newfs);
- Evd.universe_context ?names:pl evars, typ, template, imps, newps, impls, newfs
+ univs, typ, template, imps, newps, impls, newfs
let degenerate_decl decl =
let id = match RelDecl.get_name decl with
@@ -417,7 +418,6 @@ let declare_structure finite univs id idbuild paramimpls params arity template
begin
let env = Global.env () in
let env' = Environ.push_context ctx env in
- (* let env'' = Environ.push_rel_context params env' in *)
let evd = Evd.from_env env' in
Inductiveops.infer_inductive_subtyping env' evd mie
end
@@ -456,7 +456,7 @@ let declare_class finite def cum poly ctx id idbuild paramimpls params arity
let impls = implicits_of_context params in
List.map (fun x -> impls @ Impargs.lift_implicits (succ len) x) fieldimpls
in
- let binder_name = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in
+ let binder_name = Namegen.next_ident_away (snd id) (Termops.vars_of_env (Global.env())) in
let impl, projs =
match fields with
| [LocalAssum (Name proj_name, field) | LocalDef (Name proj_name, _, field)] when def ->
diff --git a/vernac/record.mli b/vernac/record.mli
index 9a0c9ef9d1..aea474581e 100644
--- a/vernac/record.mli
+++ b/vernac/record.mli
@@ -39,7 +39,7 @@ val declare_structure :
val definition_structure :
inductive_kind * Decl_kinds.cumulative_inductive_flag * Decl_kinds.polymorphic *
- Decl_kinds.recursivity_kind * plident with_coercion * local_binder_expr list *
+ Decl_kinds.recursivity_kind * ident_decl with_coercion * local_binder_expr list *
(local_decl_expr with_instance with_priority with_notation) list *
Id.t * constr_expr option -> global_reference
diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml
index e7b14309d1..6a10eb43a2 100644
--- a/vernac/topfmt.ml
+++ b/vernac/topfmt.ml
@@ -292,10 +292,11 @@ let emacs_logger = gen_logger Emacs.quote_info Emacs.quote_warning
(* This is specific to the toplevel *)
let pr_loc loc =
let fname = loc.Loc.fname in
- if CString.equal fname "" then
+ match fname with
+ | Loc.ToplevelInput ->
Loc.(str"Toplevel input, characters " ++ int loc.bp ++
str"-" ++ int loc.ep ++ str":")
- else
+ | Loc.InFile fname ->
Loc.(str"File " ++ str "\"" ++ str fname ++ str "\"" ++
str", line " ++ int loc.line_nb ++ str", characters " ++
int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++
diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib
index f74073e1f7..850902d6ba 100644
--- a/vernac/vernac.mllib
+++ b/vernac/vernac.mllib
@@ -1,4 +1,5 @@
Vernacprop
+Proof_using
Lemmas
Himsg
ExplainErr
diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml
index 4f63ed6f48..41f63644d4 100644
--- a/vernac/vernacentries.ml
+++ b/vernac/vernacentries.ml
@@ -11,7 +11,6 @@
open Pp
open CErrors
open Util
-open Flags
open Names
open Nameops
open Term
@@ -126,8 +125,8 @@ let make_cases_aux glob_ref =
| [] -> []
| (n,_)::l ->
let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n avoid in
- Id.to_string n' :: rename (n'::avoid) l in
- let al' = rename [] al in
+ Id.to_string n' :: rename (Id.Set.add n' avoid) l in
+ let al' = rename Id.Set.empty al in
let consref = ConstructRef (ith_constructor_of_inductive ind (i + 1)) in
(Libnames.string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty consref) :: al') :: l)
tarr []
@@ -409,9 +408,10 @@ let dump_global r =
(**********)
(* Syntax *)
-let vernac_syntax_extension locality local =
+let vernac_syntax_extension locality local infix l =
let local = enforce_module_locality locality local in
- Metasyntax.add_syntax_extension local
+ if infix then Metasyntax.check_infix_modifiers (snd l);
+ Metasyntax.add_syntax_extension local l
let vernac_delimiters sc = function
| Some lr -> Metasyntax.add_delimiters sc lr
@@ -430,11 +430,11 @@ let vernac_arguments_scope locality r scl =
let vernac_infix locality local =
let local = enforce_module_locality locality local in
- Metasyntax.add_infix local
+ Metasyntax.add_infix local (Global.env())
let vernac_notation locality local =
let local = enforce_module_locality locality local in
- Metasyntax.add_notation local
+ Metasyntax.add_notation local (Global.env())
(***********)
(* Gallina *)
@@ -507,7 +507,7 @@ let vernac_exact_proof c =
(* spiwack: for simplicity I do not enforce that "Proof proof_term" is
called only at the begining of a proof. *)
let status = Pfedit.by (Tactics.exact_proof c) in
- save_proof (Vernacexpr.(Proved(Opaque None,None)));
+ save_proof (Vernacexpr.(Proved(Opaque,None)));
if not status then Feedback.feedback Feedback.AddedAxiom
let vernac_assumption locality poly (local, kind) l nl =
@@ -656,7 +656,7 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast =
id binders_ast (Enforce mty_ast) []
in
Dumpglob.dump_moddef ?loc mp "mod";
- if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared");
+ Flags.if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared");
Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)]) export
let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
@@ -677,7 +677,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
export id binders_ast mty_ast_o
in
Dumpglob.dump_moddef ?loc mp "mod";
- if_verbose Feedback.msg_info
+ Flags.if_verbose Feedback.msg_info
(str "Interactive Module " ++ pr_id id ++ str " started");
List.iter
(fun (export,id) ->
@@ -695,7 +695,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
id binders_ast mty_ast_o mexpr_ast_l
in
Dumpglob.dump_moddef ?loc mp "mod";
- if_verbose Feedback.msg_info
+ Flags.if_verbose Feedback.msg_info
(str "Module " ++ pr_id id ++ str " is defined");
Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)])
export
@@ -703,7 +703,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
let vernac_end_module export (loc,id as lid) =
let mp = Declaremods.end_module () in
Dumpglob.dump_modref ?loc mp "mod";
- if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined");
+ Flags.if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined");
Option.iter (fun export -> vernac_import export [Ident lid]) export
let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
@@ -724,7 +724,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
id binders_ast mty_sign
in
Dumpglob.dump_moddef ?loc mp "modtype";
- if_verbose Feedback.msg_info
+ Flags.if_verbose Feedback.msg_info
(str "Interactive Module Type " ++ pr_id id ++ str " started");
List.iter
(fun (export,id) ->
@@ -743,13 +743,13 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
id binders_ast mty_sign mty_ast_l
in
Dumpglob.dump_moddef ?loc mp "modtype";
- if_verbose Feedback.msg_info
+ Flags.if_verbose Feedback.msg_info
(str "Module Type " ++ pr_id id ++ str " is defined")
let vernac_end_modtype (loc,id) =
let mp = Declaremods.end_modtype () in
Dumpglob.dump_modref ?loc mp "modtype";
- if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined")
+ Flags.if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined")
let vernac_include l =
Declaremods.declare_include Modintern.interp_module_ast l
@@ -817,7 +817,7 @@ let vernac_coercion locality poly local ref qids qidt =
let source = cl_of_qualid qids in
let ref' = smart_global ref in
Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target;
- if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion")
+ Flags.if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion")
let vernac_identity_coercion locality poly local id qids qidt =
let local = enforce_locality locality local in
@@ -919,7 +919,7 @@ let vernac_chdir = function
so we make it an error. *)
user_err Pp.(str ("Cd failed: " ^ err))
end;
- if_verbose Feedback.msg_info (str (Sys.getcwd()))
+ Flags.if_verbose Feedback.msg_info (str (Sys.getcwd()))
(********************)
@@ -953,7 +953,7 @@ let vernac_hints locality poly local lb h =
let vernac_syntactic_definition locality lid x local y =
Dumpglob.dump_definition lid false "syndef";
let local = enforce_module_locality locality local in
- Metasyntax.add_syntactic_definition (snd lid) x local y
+ Metasyntax.add_syntactic_definition (Global.env()) (snd lid) x local y
let vernac_declare_implicits locality r l =
let local = make_section_locality locality in
@@ -1230,7 +1230,7 @@ let vernac_reserve bl =
let env = Global.env() in
let sigma = Evd.from_env env in
let t,ctx = Constrintern.interp_type env sigma c in
- let t = Detyping.detype false [] env (Evd.from_ctx ctx) (EConstr.of_constr t) in
+ let t = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_ctx ctx) (EConstr.of_constr t) in
let t,_ = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in
Reserve.declare_reserved_type idl t)
in List.iter sb_decl bl
@@ -1301,7 +1301,7 @@ let _ =
optname = "automatic introduction of variables";
optkey = ["Automatic";"Introduction"];
optread = Flags.is_auto_intros;
- optwrite = make_auto_intros }
+ optwrite = Flags.make_auto_intros }
let _ =
declare_bool_option
@@ -1457,6 +1457,22 @@ let _ =
optread = CWarnings.get_flags;
optwrite = CWarnings.set_flags }
+let _ =
+ declare_string_option
+ { optdepr = false;
+ optname = "native_compute profiler output";
+ optkey = ["NativeCompute"; "Profile"; "Filename"];
+ optread = Nativenorm.get_profile_filename;
+ optwrite = Nativenorm.set_profile_filename }
+
+let _ =
+ declare_bool_option
+ { optdepr = false;
+ optname = "enable native compute profiling";
+ optkey = ["NativeCompute"; "Profiling"];
+ optread = Nativenorm.get_profiling_enabled;
+ optwrite = Nativenorm.set_profiling_enabled }
+
let vernac_set_strategy locality l =
let local = make_locality locality in
let glob_ref r =
@@ -1539,7 +1555,7 @@ let vernac_check_may_eval ?loc redexp glopt rc =
let sigma' = Evarconv.solve_unif_constraints_with_heuristics env sigma' in
Evarconv.check_problems_are_solved env sigma';
let sigma',nf = Evarutil.nf_evars_and_universes sigma' in
- let pl, uctx = Evd.universe_context sigma' in
+ let pl, uctx = Evd.universe_context ~names:[] ~extensible:true sigma' in
let env = Environ.push_context uctx (Evarutil.nf_env_evar sigma' env) in
let c = nf c in
let j =
@@ -1769,7 +1785,7 @@ let vernac_locate = let open Feedback in function
(Constrextern.without_symbols pr_lglob_constr) ntn sc)
| LocateLibrary qid -> print_located_library qid
| LocateModule qid -> msg_notice (print_located_module qid)
- | LocateTactic qid -> msg_notice (print_located_tactic qid)
+ | LocateOther (s, qid) -> msg_notice (print_located_other s qid)
| LocateFile f -> msg_notice (locate_file f)
let vernac_register id r =
@@ -1837,7 +1853,6 @@ let vernac_show = let open Feedback in function
| OpenSubgoals -> pr_open_subgoals ()
| NthGoal n -> pr_nth_open_subgoal n
| GoalId id -> pr_goal_by_id id
- | GoalUid id -> pr_goal_by_uid id
in
msg_notice info
| ShowProof -> show_proof ()
@@ -1886,7 +1901,7 @@ let vernac_load interp fname =
let input =
let longfname = Loadpath.locate_file fname in
let in_chan = open_utf8_file_in longfname in
- Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in
+ Pcoq.Gram.parsable ~file:(Loc.InFile longfname) (Stream.of_channel in_chan) in
try while true do interp (snd (parse_sentence input)) done
with End_of_input -> ()
@@ -1907,7 +1922,6 @@ let interp ?proof ?loc locality poly c =
| VernacTime _ -> assert false
| VernacRedirect _ -> assert false
| VernacTimeout _ -> assert false
- | VernacStm _ -> assert false
(* The STM should handle that, but LOAD bypasses the STM... *)
| VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command")
@@ -1934,8 +1948,8 @@ let interp ?proof ?loc locality poly c =
| VernacLocal _ -> assert false
(* Syntax *)
- | VernacSyntaxExtension (local,sl) ->
- vernac_syntax_extension locality local sl
+ | VernacSyntaxExtension (infix, local,sl) ->
+ vernac_syntax_extension locality local infix sl
| VernacDelimiters (sc,lr) -> vernac_delimiters sc lr
| VernacBindScope (sc,rl) -> vernac_bind_scope sc rl
| VernacOpenCloseScope (local, s) -> vernac_open_close_scope locality local s
@@ -2033,7 +2047,7 @@ let interp ?proof ?loc locality poly c =
| VernacSearch (s,g,r) -> vernac_search ?loc s g r
| VernacLocate l -> vernac_locate l
| VernacRegister (id, r) -> vernac_register id r
- | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n")
+ | VernacComments l -> Flags.if_verbose Feedback.msg_info (str "Comments ok\n")
(* Proof management *)
| VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t)]
@@ -2045,21 +2059,17 @@ let interp ?proof ?loc locality poly c =
| VernacEndSubproof -> vernac_end_subproof ()
| VernacShow s -> vernac_show s
| VernacCheckGuard -> vernac_check_guard ()
- | VernacProof (None, None) ->
- Aux_file.record_in_aux_at ?loc "VernacProof" "tac:no using:no"
- | VernacProof (Some tac, None) ->
- Aux_file.record_in_aux_at ?loc "VernacProof" "tac:yes using:no";
- vernac_set_end_tac tac
- | VernacProof (None, Some l) ->
- Aux_file.record_in_aux_at ?loc "VernacProof" "tac:no using:yes";
- vernac_set_used_variables l
- | VernacProof (Some tac, Some l) ->
- Aux_file.record_in_aux_at ?loc "VernacProof" "tac:yes using:yes";
- vernac_set_end_tac tac; vernac_set_used_variables l
+ | VernacProof (tac, using) ->
+ let using = Option.append using (Proof_using.get_default_proof_using ()) in
+ let tacs = if Option.is_empty tac then "tac:no" else "tac:yes" in
+ let usings = if Option.is_empty using then "using:no" else "using:yes" in
+ Aux_file.record_in_aux_at ?loc "VernacProof" (tacs^" "^usings);
+ Option.iter vernac_set_end_tac tac;
+ Option.iter vernac_set_used_variables using
| VernacProofMode mn -> Proof_global.set_proof_mode mn [@ocaml.warning "-3"]
(* Extensions *)
- | VernacExtend (opn,args) -> Vernacinterp.call ?locality (opn,args)
+ | VernacExtend (opn,args) -> Vernacinterp.call ?locality ?loc (opn,args)
(* Vernaculars that take a locality flag *)
let check_vernac_supports_locality c l =
@@ -2137,41 +2147,62 @@ let locate_if_not_already ?loc (e, info) =
exception HasNotFailed
exception HasFailed of Pp.t
-let with_fail b f =
- if not b then f ()
+type interp_state = { (* TODO: inline records in OCaml 4.03 *)
+ system : States.state; (* summary + libstack *)
+ proof : Proof_global.state; (* proof state *)
+ shallow : bool (* is the state trimmed down (libstack) *)
+}
+
+let s_cache = ref (States.freeze ~marshallable:`No)
+let s_proof = ref (Proof_global.freeze ~marshallable:`No)
+
+let invalidate_cache () =
+ s_cache := Obj.magic 0;
+ s_proof := Obj.magic 0
+
+let freeze_interp_state marshallable =
+ { system = (s_cache := States.freeze ~marshallable; !s_cache);
+ proof = (s_proof := Proof_global.freeze ~marshallable; !s_proof);
+ shallow = marshallable = `Shallow }
+
+let unfreeze_interp_state { system; proof } =
+ if (!s_cache != system) then (s_cache := system; States.unfreeze system);
+ if (!s_proof != proof) then (s_proof := proof; Proof_global.unfreeze proof)
+
+(* XXX STATE: this type hints that restoring the state should be the
+ caller's responsibility *)
+let with_fail st b f =
+ if not b
+ then f ()
else begin try
(* If the command actually works, ignore its effects on the state.
* Note that error has to be printed in the right state, hence
* within the purified function *)
- Future.purify
- (fun v ->
- try f v; raise HasNotFailed
- with
- | HasNotFailed as e -> raise e
- | e ->
- let e = CErrors.push e in
- raise (HasFailed (CErrors.iprint
- (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e))))
- ()
+ try f (); raise HasNotFailed
+ with
+ | HasNotFailed as e -> raise e
+ | e ->
+ let e = CErrors.push e in
+ raise (HasFailed (CErrors.iprint
+ (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e)))
with e when CErrors.noncritical e ->
+ (* Restore the previous state XXX Careful here with the cache! *)
+ invalidate_cache ();
+ unfreeze_interp_state st;
let (e, _) = CErrors.push e in
match e with
| HasNotFailed ->
user_err ~hdr:"Fail" (str "The command has not failed!")
| HasFailed msg ->
- if not !Flags.quiet || !test_mode || !ide_slave then Feedback.msg_info
+ if not !Flags.quiet || !Flags.test_mode || !Flags.ide_slave then Feedback.msg_info
(str "The command has indeed failed with message:" ++ fnl () ++ msg)
| _ -> assert false
end
-let interp ?(verbosely=true) ?proof (loc,c) =
+let interp ?(verbosely=true) ?proof st (loc,c) =
let orig_program_mode = Flags.is_program_mode () in
let rec aux ?locality ?polymorphism isprogcmd = function
- (* This assert case will be removed when fake_ide can understand
- completion feedback *)
- | VernacStm _ -> assert false (* Done by Stm *)
-
| VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c
| VernacProgram _ -> user_err Pp.(str "Program mode specified twice")
| VernacLocal (b, c) when Option.is_empty locality ->
@@ -2181,7 +2212,7 @@ let interp ?(verbosely=true) ?proof (loc,c) =
| VernacPolymorphic (b, c) -> user_err Pp.(str "Polymorphism specified twice")
| VernacLocal _ -> user_err Pp.(str "Locality specified twice")
| VernacFail v ->
- with_fail true (fun () -> aux ?locality ?polymorphism isprogcmd v)
+ with_fail st true (fun () -> aux ?locality ?polymorphism isprogcmd v)
| VernacTimeout (n,v) ->
current_timeout := Some n;
aux ?locality ?polymorphism isprogcmd v
@@ -2220,3 +2251,8 @@ let interp ?(verbosely=true) ?proof (loc,c) =
in
if verbosely then Flags.verbosely (aux false) c
else aux false c
+
+let interp ?verbosely ?proof st cmd =
+ unfreeze_interp_state st;
+ interp ?verbosely ?proof st cmd;
+ freeze_interp_state `No
diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli
index a09011d245..56635c8011 100644
--- a/vernac/vernacentries.mli
+++ b/vernac/vernacentries.mli
@@ -14,11 +14,21 @@ val dump_global : Libnames.reference or_by_notation -> unit
val vernac_require :
Libnames.reference option -> bool option -> Libnames.reference list -> unit
+type interp_state = { (* TODO: inline records in OCaml 4.03 *)
+ system : States.state; (* summary + libstack *)
+ proof : Proof_global.state; (* proof state *)
+ shallow : bool (* is the state trimmed down (libstack) *)
+}
+
+val freeze_interp_state : Summary.marshallable -> interp_state
+val unfreeze_interp_state : interp_state -> unit
+
(** The main interpretation function of vernacular expressions *)
val interp :
?verbosely:bool ->
?proof:Proof_global.closed_proof ->
- Vernacexpr.vernac_expr Loc.located -> unit
+ interp_state ->
+ Vernacexpr.vernac_expr Loc.located -> interp_state
(** Prepare a "match" template for a given inductive type.
For each branch of the match, we list the constructor name
@@ -28,7 +38,9 @@ val interp :
val make_cases : string -> string list list
-val with_fail : bool -> (unit -> unit) -> unit
+(* XXX STATE: this type hints that restoring the state should be the
+ caller's responsibility *)
+val with_fail : interp_state -> bool -> (unit -> unit) -> unit
val command_focus : unit Proof.focus_kind
diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml
index 2d9c0fa362..41fee6bd08 100644
--- a/vernac/vernacinterp.ml
+++ b/vernac/vernacinterp.ml
@@ -11,7 +11,7 @@ open Pp
open CErrors
type deprecation = bool
-type vernac_command = Genarg.raw_generic_argument list -> unit -> unit
+type vernac_command = Genarg.raw_generic_argument list -> Loc.t option -> unit
(* Table of vernac entries *)
let vernac_tab =
@@ -49,8 +49,8 @@ let warn_deprecated_command =
(* Interpretation of a vernac command *)
-let call ?locality (opn,converted_args) =
- let loc = ref "Looking up command" in
+let call ?locality ?loc (opn,converted_args) =
+ let phase = ref "Looking up command" in
try
let depr, callback = vinterp_map opn in
let () = if depr then
@@ -62,16 +62,16 @@ let call ?locality (opn,converted_args) =
let pr = pr_sequence pr_gram rules in
warn_deprecated_command pr;
in
- loc:= "Checking arguments";
+ phase := "Checking arguments";
let hunk = callback converted_args in
- loc:= "Executing command";
+ phase := "Executing command";
Locality.LocalityFixme.set locality;
- hunk();
+ hunk loc;
Locality.LocalityFixme.assert_consumed()
with
| Drop -> raise Drop
| reraise ->
let reraise = CErrors.push reraise in
if !Flags.debug then
- Feedback.msg_debug (str"Vernac Interpreter " ++ str !loc);
+ Feedback.msg_debug (str"Vernac Interpreter " ++ str !phase);
iraise reraise
diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli
index f58d070864..84370fdc29 100644
--- a/vernac/vernacinterp.mli
+++ b/vernac/vernacinterp.mli
@@ -9,7 +9,7 @@
(** Interpretation of extended vernac phrases. *)
type deprecation = bool
-type vernac_command = Genarg.raw_generic_argument list -> unit -> unit
+type vernac_command = Genarg.raw_generic_argument list -> Loc.t option -> unit
val vinterp_add : deprecation -> Vernacexpr.extend_name ->
vernac_command -> unit
@@ -17,4 +17,4 @@ val overwriting_vinterp_add :
Vernacexpr.extend_name -> vernac_command -> unit
val vinterp_init : unit -> unit
-val call : ?locality:bool -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit
+val call : ?locality:bool -> ?loc:Loc.t -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit
diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml
index fc11bcf4a0..3cff1f14c0 100644
--- a/vernac/vernacprop.ml
+++ b/vernac/vernacprop.ml
@@ -17,8 +17,7 @@ let rec is_navigation_vernac = function
| VernacResetName _
| VernacBacktrack _
| VernacBackTo _
- | VernacBack _
- | VernacStm _ -> true
+ | VernacBack _ -> true
| VernacRedirect (_, (_,c))
| VernacTime (_,c) ->
is_navigation_vernac c (* Time Back* is harmless *)
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-04 09:13:26 +0000