summaryrefslogtreecommitdiff
path: root/toplevel
diff options
context:
space:
mode:
authorGravatar Benjamin Barenblat <bbaren@debian.org>2018-12-29 14:31:27 -0500
committerGravatar Benjamin Barenblat <bbaren@debian.org>2018-12-29 14:31:27 -0500
commit9043add656177eeac1491a73d2f3ab92bec0013c (patch)
tree2b0092c84bfbf718eca10c81f60b2640dc8cab05 /toplevel
parenta4c7f8bd98be2a200489325ff7c5061cf80ab4f3 (diff)
Imported Upstream version 8.8.2upstream/8.8.2
Diffstat (limited to 'toplevel')
-rw-r--r--toplevel/assumptions.ml318
-rw-r--r--toplevel/assumptions.mli31
-rw-r--r--toplevel/auto_ind_decl.ml960
-rw-r--r--toplevel/auto_ind_decl.mli41
-rw-r--r--toplevel/class.ml328
-rw-r--r--toplevel/class.mli48
-rw-r--r--toplevel/classes.ml408
-rw-r--r--toplevel/classes.mli66
-rw-r--r--toplevel/command.ml1355
-rw-r--r--toplevel/command.mli176
-rw-r--r--toplevel/coqargs.ml584
-rw-r--r--toplevel/coqargs.mli65
-rw-r--r--toplevel/coqinit.ml172
-rw-r--r--toplevel/coqinit.mli29
-rw-r--r--toplevel/coqloop.ml357
-rw-r--r--toplevel/coqloop.mli33
-rw-r--r--toplevel/coqtop.ml982
-rw-r--r--toplevel/coqtop.mli18
-rw-r--r--toplevel/coqtop_byte_bin.ml34
-rw-r--r--toplevel/coqtop_opt_bin.ml16
-rw-r--r--toplevel/discharge.ml120
-rw-r--r--toplevel/discharge.mli14
-rw-r--r--toplevel/doc.tex10
-rw-r--r--toplevel/explainErr.ml129
-rw-r--r--toplevel/explainErr.mli21
-rw-r--r--toplevel/himsg.ml1267
-rw-r--r--toplevel/himsg.mli42
-rw-r--r--toplevel/ind_tables.ml203
-rw-r--r--toplevel/ind_tables.mli51
-rw-r--r--toplevel/indschemes.ml524
-rw-r--r--toplevel/indschemes.mli49
-rw-r--r--toplevel/locality.ml107
-rw-r--r--toplevel/locality.mli51
-rw-r--r--toplevel/metasyntax.ml1379
-rw-r--r--toplevel/metasyntax.mli60
-rw-r--r--toplevel/mltop.ml447
-rw-r--r--toplevel/mltop.mli88
-rw-r--r--toplevel/obligations.ml1171
-rw-r--r--toplevel/obligations.mli113
-rw-r--r--toplevel/record.ml579
-rw-r--r--toplevel/record.mli46
-rw-r--r--toplevel/search.ml315
-rw-r--r--toplevel/search.mli76
-rw-r--r--toplevel/toplevel.mllib17
-rw-r--r--toplevel/usage.ml36
-rw-r--r--toplevel/usage.mli12
-rw-r--r--toplevel/vernac.ml470
-rw-r--r--toplevel/vernac.mli59
-rw-r--r--toplevel/vernacentries.ml2257
-rw-r--r--toplevel/vernacentries.mli66
-rw-r--r--toplevel/vernacinterp.ml77
-rw-r--r--toplevel/vernacinterp.mli20
52 files changed, 1665 insertions, 14232 deletions
diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml
deleted file mode 100644
index 45c539e2..00000000
--- a/toplevel/assumptions.ml
+++ /dev/null
@@ -1,318 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* The following definitions are used by the function
- [assumptions] which gives as an output the set of all
- axioms and sections variables on which a given term depends
- in a context (expectingly the Global context) *)
-
-(* Initial author: Arnaud Spiwack
- Module-traversing code: Pierre Letouzey *)
-
-open Pp
-open CErrors
-open Util
-open Names
-open Term
-open Declarations
-open Mod_subst
-open Globnames
-open Printer
-open Context.Named.Declaration
-
-(** For a constant c in a module sealed by an interface (M:T and
- not M<:T), [Global.lookup_constant] may return a [constant_body]
- without body. We fix this by looking in the implementation
- of the module *)
-
-let modcache = ref (MPmap.empty : structure_body MPmap.t)
-
-let rec search_mod_label lab = function
- | [] -> raise Not_found
- | (l, SFBmodule mb) :: _ when Label.equal l lab -> mb
- | _ :: fields -> search_mod_label lab fields
-
-let rec search_cst_label lab = function
- | [] -> raise Not_found
- | (l, SFBconst cb) :: _ when Label.equal l lab -> cb
- | _ :: fields -> search_cst_label lab fields
-
-(* TODO: using [empty_delta_resolver] below is probably slightly incorrect. But:
- a) I don't see currently what should be used instead
- b) this shouldn't be critical for Print Assumption. At worse some
- constants will have a canonical name which is non-canonical,
- leading to failures in [Global.lookup_constant], but our own
- [lookup_constant] should work.
-*)
-
-let rec fields_of_functor f subs mp0 args = function
- |NoFunctor a -> f subs mp0 args a
- |MoreFunctor (mbid,_,e) ->
- match args with
- | [] -> assert false (* we should only encounter applied functors *)
- | mpa :: args ->
- let subs = join (map_mbid mbid mpa empty_delta_resolver (*TODO*)) subs in
- fields_of_functor f subs mp0 args e
-
-let rec lookup_module_in_impl mp =
- try Global.lookup_module mp
- with Not_found ->
- (* The module we search might not be exported by its englobing module(s).
- We access the upper layer, and then do a manual search *)
- match mp with
- | MPfile _ -> raise Not_found (* can happen if mp is an open module *)
- | MPbound _ -> assert false
- | MPdot (mp',lab') ->
- let fields = memoize_fields_of_mp mp' in
- search_mod_label lab' fields
-
-and memoize_fields_of_mp mp =
- try MPmap.find mp !modcache
- with Not_found ->
- let l = fields_of_mp mp in
- modcache := MPmap.add mp l !modcache;
- l
-
-and fields_of_mp mp =
- let mb = lookup_module_in_impl mp in
- let fields,inner_mp,subs = fields_of_mb empty_subst mb [] in
- let subs =
- if mp_eq inner_mp mp then subs
- else add_mp inner_mp mp mb.mod_delta subs
- in
- Modops.subst_structure subs fields
-
-and fields_of_mb subs mb args = match mb.mod_expr with
- |Algebraic expr -> fields_of_expression subs mb.mod_mp args expr
- |Struct sign -> fields_of_signature subs mb.mod_mp args sign
- |Abstract|FullStruct -> fields_of_signature subs mb.mod_mp args mb.mod_type
-
-(** The Abstract case above corresponds to [Declare Module] *)
-
-and fields_of_signature x =
- fields_of_functor
- (fun subs mp0 args struc ->
- assert (List.is_empty args);
- (struc, mp0, subs)) x
-
-and fields_of_expr subs mp0 args = function
- |MEident mp ->
- let mb = lookup_module_in_impl (subst_mp subs mp) in
- fields_of_mb subs mb args
- |MEapply (me1,mp2) -> fields_of_expr subs mp0 (mp2::args) me1
- |MEwith _ -> assert false (* no 'with' in [mod_expr] *)
-
-and fields_of_expression x = fields_of_functor fields_of_expr x
-
-let lookup_constant_in_impl cst fallback =
- try
- let mp,dp,lab = repr_kn (canonical_con cst) in
- let fields = memoize_fields_of_mp mp in
- (* A module found this way is necessarily closed, in particular
- our constant cannot be in an opened section : *)
- search_cst_label lab fields
- with Not_found ->
- (* Either:
- - The module part of the constant isn't registered yet :
- we're still in it, so the [constant_body] found earlier
- (if any) was a true axiom.
- - The label has not been found in the structure. This is an error *)
- match fallback with
- | Some cb -> cb
- | None -> anomaly (str "Print Assumption: unknown constant " ++ pr_con cst)
-
-let lookup_constant cst =
- try
- let cb = Global.lookup_constant cst in
- if Declareops.constant_has_body cb then cb
- else lookup_constant_in_impl cst (Some cb)
- with Not_found -> lookup_constant_in_impl cst None
-
-(** Graph traversal of an object, collecting on the way the dependencies of
- traversed objects *)
-
-let label_of = function
- | ConstRef kn -> pi3 (repr_con kn)
- | IndRef (kn,_)
- | ConstructRef ((kn,_),_) -> pi3 (repr_mind kn)
- | VarRef id -> Label.of_id id
-
-let rec traverse current ctx accu t = match kind_of_term t with
-| Var id ->
- let body () = Global.lookup_named id |> get_value in
- traverse_object accu body (VarRef id)
-| Const (kn, _) ->
- let body () = Global.body_of_constant_body (lookup_constant kn) in
- traverse_object accu body (ConstRef kn)
-| Ind ((mind, _) as ind, _) ->
- traverse_inductive accu mind (IndRef ind)
-| Construct (((mind, _), _) as cst, _) ->
- traverse_inductive accu mind (ConstructRef cst)
-| Meta _ | Evar _ -> assert false
-| Case (_,oty,c,[||]) ->
- (* non dependent match on an inductive with no constructors *)
- begin match Constr.(kind oty, kind c) with
- | Lambda(_,_,oty), Const (kn, _)
- when Vars.noccurn 1 oty &&
- not (Declareops.constant_has_body (lookup_constant kn)) ->
- let body () = Global.body_of_constant_body (lookup_constant kn) in
- traverse_object
- ~inhabits:(current,ctx,Vars.subst1 mkProp oty) accu body (ConstRef kn)
- | _ ->
- Termops.fold_constr_with_full_binders
- Context.Rel.add (traverse current) ctx accu t
- end
-| _ -> Termops.fold_constr_with_full_binders
- Context.Rel.add (traverse current) ctx accu t
-
-and traverse_object ?inhabits (curr, data, ax2ty) body obj =
- let data, ax2ty =
- let already_in = Refmap_env.mem obj data in
- match body () with
- | None ->
- let data =
- if not already_in then Refmap_env.add obj Refset_env.empty data else data in
- let ax2ty =
- if Option.is_empty inhabits then ax2ty else
- let ty = Option.get inhabits in
- try let l = Refmap_env.find obj ax2ty in Refmap_env.add obj (ty::l) ax2ty
- with Not_found -> Refmap_env.add obj [ty] ax2ty in
- data, ax2ty
- | Some body ->
- if already_in then data, ax2ty else
- let contents,data,ax2ty =
- traverse (label_of obj) Context.Rel.empty
- (Refset_env.empty,data,ax2ty) body in
- Refmap_env.add obj contents data, ax2ty
- in
- (Refset_env.add obj curr, data, ax2ty)
-
-(** Collects the references occurring in the declaration of mutual inductive
- definitions. All the constructors and names of a mutual inductive
- definition share exactly the same dependencies. Also, there is no explicit
- dependency between mutually defined inductives and constructors. *)
-and traverse_inductive (curr, data, ax2ty) mind obj =
- let firstind_ref = (IndRef (mind, 0)) in
- let label = label_of obj in
- let data, ax2ty =
- (* Invariant : I_0 \in data iff I_i \in data iff c_ij \in data
- where I_0, I_1, ... are in the same mutual definition and c_ij
- are all their constructors. *)
- if Refmap_env.mem firstind_ref data then data, ax2ty else
- let mib = Global.lookup_mind mind in
- (* Collects references of parameters *)
- let param_ctx = mib.mind_params_ctxt in
- let nparam = List.length param_ctx in
- let accu =
- traverse_context label Context.Rel.empty
- (Refset_env.empty, data, ax2ty) param_ctx
- in
- (* Build the context of all arities *)
- let arities_ctx =
- let global_env = Global.env () in
- Array.fold_left (fun accu oib ->
- let pspecif = Univ.in_punivs (mib, oib) in
- let ind_type = Inductive.type_of_inductive global_env pspecif in
- let ind_name = Name oib.mind_typename in
- Context.Rel.add (Context.Rel.Declaration.LocalAssum (ind_name, ind_type)) accu)
- Context.Rel.empty mib.mind_packets
- in
- (* For each inductive, collects references in their arity and in the type
- of constructors*)
- let (contents, data, ax2ty) = Array.fold_left (fun accu oib ->
- let arity_wo_param =
- List.rev (List.skipn nparam (List.rev oib.mind_arity_ctxt))
- in
- let accu =
- traverse_context
- label param_ctx accu arity_wo_param
- in
- Array.fold_left (fun accu cst_typ ->
- let param_ctx, cst_typ_wo_param = Term.decompose_prod_n_assum nparam cst_typ in
- let ctx = Context.(Rel.fold_outside Context.Rel.add ~init:arities_ctx param_ctx) in
- traverse label ctx accu cst_typ_wo_param)
- accu oib.mind_user_lc)
- accu mib.mind_packets
- in
- (* Maps all these dependencies to inductives and constructors*)
- let data = Array.fold_left_i (fun n data oib ->
- let ind = (mind, n) in
- let data = Refmap_env.add (IndRef ind) contents data in
- Array.fold_left_i (fun k data _ ->
- Refmap_env.add (ConstructRef (ind, k+1)) contents data
- ) data oib.mind_consnames) data mib.mind_packets
- in
- data, ax2ty
- in
- (Refset_env.add obj curr, data, ax2ty)
-
-(** Collects references in a rel_context. *)
-and traverse_context current ctx accu ctxt =
- snd (Context.Rel.fold_outside (fun decl (ctx, accu) ->
- match decl with
- | Context.Rel.Declaration.LocalDef (_,c,t) ->
- let accu = traverse current ctx (traverse current ctx accu t) c in
- let ctx = Context.Rel.add decl ctx in
- ctx, accu
- | Context.Rel.Declaration.LocalAssum (_,t) ->
- let accu = traverse current ctx accu t in
- let ctx = Context.Rel.add decl ctx in
- ctx, accu) ctxt ~init:(ctx, accu))
-
-let traverse current t =
- let () = modcache := MPmap.empty in
- traverse current Context.Rel.empty (Refset_env.empty, Refmap_env.empty, Refmap_env.empty) t
-
-(** Hopefully bullet-proof function to recover the type of a constant. It just
- ignores all the universe stuff. There are many issues that can arise when
- considering terms out of any valid environment, so use with caution. *)
-let type_of_constant cb = match cb.Declarations.const_type with
-| Declarations.RegularArity ty -> ty
-| Declarations.TemplateArity (ctx, arity) ->
- Term.mkArity (ctx, Sorts.sort_of_univ arity.Declarations.template_level)
-
-let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t =
- let (idts, knst) = st in
- (** Only keep the transitive dependencies *)
- let (_, graph, ax2ty) = traverse (label_of gr) t in
- let fold obj _ accu = match obj with
- | VarRef id ->
- let decl = Global.lookup_named id in
- if is_local_assum decl then
- let t = Context.Named.Declaration.get_type decl in
- ContextObjectMap.add (Variable id) t accu
- else accu
- | ConstRef kn ->
- let cb = lookup_constant kn in
- let accu =
- if cb.const_typing_flags.check_guarded then accu
- else
- let l = try Refmap_env.find obj ax2ty with Not_found -> [] in
- ContextObjectMap.add (Axiom (Guarded kn, l)) Constr.mkProp accu
- in
- if not (Declareops.constant_has_body cb) || not cb.const_typing_flags.check_universes then
- let t = type_of_constant cb in
- let l = try Refmap_env.find obj ax2ty with Not_found -> [] in
- ContextObjectMap.add (Axiom (Constant kn,l)) t accu
- else if add_opaque && (Declareops.is_opaque cb || not (Cpred.mem kn knst)) then
- let t = type_of_constant cb in
- ContextObjectMap.add (Opaque kn) t accu
- else if add_transparent then
- let t = type_of_constant cb in
- ContextObjectMap.add (Transparent kn) t accu
- else
- accu
- | IndRef (m,_) | ConstructRef ((m,_),_) ->
- let mind = Global.lookup_mind m in
- if mind.mind_typing_flags.check_guarded then
- accu
- else
- let l = try Refmap_env.find obj ax2ty with Not_found -> [] in
- ContextObjectMap.add (Axiom (Positive m, l)) Constr.mkProp accu
- in
- Refmap_env.fold fold graph ContextObjectMap.empty
diff --git a/toplevel/assumptions.mli b/toplevel/assumptions.mli
deleted file mode 100644
index 07267578..00000000
--- a/toplevel/assumptions.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open Term
-open Globnames
-open Printer
-
-(** Collects all the objects on which a term directly relies, bypassing kernel
- opacity, together with the recursive dependence DAG of objects.
-
- WARNING: some terms may not make sense in the environment, because they are
- sealed inside opaque modules. Do not try to do anything fancy with those
- terms apart from printing them, otherwise demons may fly out of your nose.
-*)
-val traverse :
- Label.t -> constr ->
- (Refset_env.t * Refset_env.t Refmap_env.t *
- (label * Context.Rel.t * types) list Refmap_env.t)
-
-(** Collects all the assumptions (optionally including opaque definitions)
- on which a term relies (together with their type). The above warning of
- {!traverse} also applies. *)
-val assumptions :
- ?add_opaque:bool -> ?add_transparent:bool -> transparent_state ->
- global_reference -> constr -> Term.types ContextObjectMap.t
diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml
deleted file mode 100644
index 0561fc4b..00000000
--- a/toplevel/auto_ind_decl.ml
+++ /dev/null
@@ -1,960 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* This file is about the automatic generation of schemes about
- decidable equality, created by Vincent Siles, Oct 2007 *)
-
-open Tacmach
-open CErrors
-open Util
-open Pp
-open Term
-open Vars
-open Termops
-open Declarations
-open Names
-open Globnames
-open Nameops
-open Inductiveops
-open Tactics
-open Ind_tables
-open Misctypes
-open Proofview.Notations
-open Context.Rel.Declaration
-
-let out_punivs = Univ.out_punivs
-
-(**********************************************************************)
-(* Generic synthesis of boolean equality *)
-
-let quick_chop n l =
- let rec kick_last = function
- | t::[] -> []
- | t::q -> t::(kick_last q)
- | [] -> failwith "kick_last"
-and aux = function
- | (0,l') -> l'
- | (n,h::t) -> aux (n-1,t)
- | _ -> failwith "quick_chop"
- in
- if n > (List.length l) then failwith "quick_chop args"
- else kick_last (aux (n,l) )
-
-let deconstruct_type t =
- let l,r = decompose_prod t in
- (List.rev_map snd l)@[r]
-
-exception EqNotFound of inductive * inductive
-exception EqUnknown of string
-exception UndefinedCst of string
-exception InductiveWithProduct
-exception InductiveWithSort
-exception ParameterWithoutEquality of global_reference
-exception NonSingletonProp of inductive
-exception DecidabilityMutualNotSupported
-
-let dl = Loc.ghost
-
-let constr_of_global g = lazy (Universes.constr_of_global g)
-
-(* Some pre declaration of constant we are going to use *)
-let bb = constr_of_global Coqlib.glob_bool
-
-let andb_prop = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb_prop
-
-let andb_true_intro = fun _ ->
- (Coqlib.build_bool_type()).Coqlib.andb_true_intro
-
-let tt = constr_of_global Coqlib.glob_true
-
-let ff = constr_of_global Coqlib.glob_false
-
-let eq = constr_of_global Coqlib.glob_eq
-
-let sumbool = Coqlib.build_coq_sumbool
-
-let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb
-
-let induct_on c = induction false None c None None
-
-let destruct_on c = destruct false None c None None
-
-let destruct_on_using c id =
- destruct false None c
- (Some (dl,IntroOrPattern [[dl,IntroNaming IntroAnonymous];
- [dl,IntroNaming (IntroIdentifier id)]]))
- None
-
-let destruct_on_as c l =
- destruct false None c (Some (dl,l)) None
-
-(* reconstruct the inductive with the correct deBruijn indexes *)
-let mkFullInd (ind,u) n =
- let mib = Global.lookup_mind (fst ind) in
- let nparams = mib.mind_nparams in
- let nparrec = mib.mind_nparams_rec in
- (* params context divided *)
- let lnonparrec,lnamesparrec =
- context_chop (nparams-nparrec) mib.mind_params_ctxt in
- if nparrec > 0
- then mkApp (mkIndU (ind,u),
- Array.of_list(Context.Rel.to_extended_list (nparrec+n) lnamesparrec))
- else mkIndU (ind,u)
-
-let check_bool_is_defined () =
- try let _ = Global.type_of_global_unsafe Coqlib.glob_bool in ()
- with e when CErrors.noncritical e -> raise (UndefinedCst "bool")
-
-let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
-
-let build_beq_scheme mode kn =
- check_bool_is_defined ();
- (* fetching global env *)
- let env = Global.env() in
- (* fetching the mutual inductive body *)
- let mib = Global.lookup_mind kn in
- (* number of inductives in the mutual *)
- let nb_ind = Array.length mib.mind_packets in
- (* number of params in the type *)
- let nparams = mib.mind_nparams in
- let nparrec = mib.mind_nparams_rec in
- (* params context divided *)
- let lnonparrec,lnamesparrec =
- context_chop (nparams-nparrec) mib.mind_params_ctxt in
- (* predef coq's boolean type *)
- (* rec name *)
- let rec_name i =(Id.to_string (Array.get mib.mind_packets i).mind_typename)^
- "_eqrec"
- in
- (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *)
- let create_input c =
- let myArrow u v = mkArrow u (lift 1 v)
- and eqName = function
- | Name s -> Id.of_string ("eq_"^(Id.to_string s))
- | Anonymous -> Id.of_string "eq_A"
- in
- let ext_rel_list = Context.Rel.to_extended_list 0 lnamesparrec in
- let lift_cnt = ref 0 in
- let eqs_typ = List.map (fun aa ->
- let a = lift !lift_cnt aa in
- incr lift_cnt;
- myArrow a (myArrow a (Lazy.force bb))
- ) ext_rel_list in
-
- let eq_input = List.fold_left2
- ( fun a b decl -> (* mkLambda(n,b,a) ) *)
- (* here I leave the Naming thingy so that the type of
- the function is more readable for the user *)
- mkNamedLambda (eqName (get_name decl)) b a )
- c (List.rev eqs_typ) lnamesparrec
- in
- List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *)
- (* Same here , hoping the auto renaming will do something good ;) *)
- mkNamedLambda
- (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A")
- (get_type decl) a) eq_input lnamesparrec
- in
- let make_one_eq cur =
- let u = Univ.Instance.empty in
- let ind = (kn,cur),u (* FIXME *) in
- (* current inductive we are working on *)
- let cur_packet = mib.mind_packets.(snd (fst ind)) in
- (* Inductive toto : [rettyp] := *)
- let rettyp = Inductive.type_of_inductive env ((mib,cur_packet),u) in
- (* split rettyp in a list without the non rec params and the last ->
- e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *)
- let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in
- (* give a type A, this function tries to find the equality on A declared
- previously *)
- (* nlist = the number of args (A , B , ... )
- eqA = the deBruijn index of the first eq param
- ndx = how much to translate due to the 2nd Case
- *)
- let compute_A_equality rel_list nlist eqA ndx t =
- let lifti = ndx in
- let rec aux c =
- let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in
- match kind_of_term 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 () =
- try ignore (Environ.lookup_named eid env)
- with Not_found -> raise (ParameterWithoutEquality (VarRef x))
- in
- mkVar eid, Safe_typing.empty_private_constants
- | Cast (x,_,_) -> aux (applist (x,a))
- | App _ -> assert false
- | Ind ((kn',i as ind'),u) (*FIXME: universes *) ->
- if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Safe_typing.empty_private_constants
- else begin
- try
- let eq, eff =
- let c, eff = find_scheme ~mode (!beq_scheme_kind_aux()) (kn',i) in
- mkConst c, eff in
- let eqa, eff =
- let eqa, effs = List.split (List.map aux a) in
- Array.of_list eqa,
- List.fold_left Safe_typing.concat_private eff (List.rev effs)
- in
- let args =
- Array.append
- (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in
- if Int.equal (Array.length args) 0 then eq, eff
- else mkApp (eq, args), eff
- with Not_found -> raise(EqNotFound (ind', fst ind))
- end
- | Sort _ -> raise InductiveWithSort
- | Prod _ -> raise InductiveWithProduct
- | Lambda _-> raise (EqUnknown "Lambda")
- | LetIn _ -> raise (EqUnknown "LetIn")
- | Const kn ->
- (match Environ.constant_opt_value_in env kn with
- | None -> raise (ParameterWithoutEquality (ConstRef (fst kn)))
- | Some c -> aux (applist (c,a)))
- | Proj _ -> raise (EqUnknown "Proj")
- | Construct _ -> raise (EqUnknown "Construct")
- | Case _ -> raise (EqUnknown "Case")
- | CoFix _ -> raise (EqUnknown "CoFix")
- | Fix _ -> raise (EqUnknown "Fix")
- | Meta _ -> raise (EqUnknown "Meta")
- | Evar _ -> raise (EqUnknown "Evar")
- in
- aux t
- in
- (* construct the predicate for the Case part*)
- let do_predicate rel_list n =
- List.fold_left (fun a b -> mkLambda(Anonymous,b,a))
- (mkLambda (Anonymous,
- mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1),
- (Lazy.force bb)))
- (List.rev rettyp_l) in
- (* make_one_eq *)
- (* do the [| C1 ... => match Y with ... end
- ...
- Cn => match Y with ... end |] part *)
- let ci = make_case_info env (fst ind) MatchStyle in
- let constrs n = get_constructors env (make_ind_family (ind,
- Context.Rel.to_extended_list (n+nb_ind-1) mib.mind_params_ctxt)) in
- let constrsi = constrs (3+nparrec) in
- let n = Array.length constrsi in
- let ar = Array.make n (Lazy.force ff) in
- let eff = ref Safe_typing.empty_private_constants in
- for i=0 to n-1 do
- let nb_cstr_args = List.length constrsi.(i).cs_args in
- let ar2 = Array.make n (Lazy.force ff) in
- let constrsj = constrs (3+nparrec+nb_cstr_args) in
- for j=0 to n-1 do
- if Int.equal i j then
- ar2.(j) <- let cc = (match nb_cstr_args with
- | 0 -> Lazy.force tt
- | _ -> let eqs = Array.make nb_cstr_args (Lazy.force tt) in
- for ndx = 0 to nb_cstr_args-1 do
- let cc = get_type (List.nth constrsi.(i).cs_args ndx) in
- let eqA, eff' = compute_A_equality rel_list
- nparrec
- (nparrec+3+2*nb_cstr_args)
- (nb_cstr_args+ndx+1)
- cc
- in
- eff := Safe_typing.concat_private eff' !eff;
- Array.set eqs ndx
- (mkApp (eqA,
- [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|]
- ))
- done;
- Array.fold_left
- (fun a b -> mkApp (andb(),[|b;a|]))
- (eqs.(0))
- (Array.sub eqs 1 (nb_cstr_args - 1))
- )
- in
- (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) cc
- (constrsj.(j).cs_args)
- )
- else ar2.(j) <- (List.fold_left (fun a decl ->
- mkLambda (get_name decl, get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) )
- done;
-
- ar.(i) <- (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a))
- (mkCase (ci,do_predicate rel_list nb_cstr_args,
- mkVar (Id.of_string "Y") ,ar2))
- (constrsi.(i).cs_args))
- done;
- mkNamedLambda (Id.of_string "X") (mkFullInd ind (nb_ind-1+1)) (
- mkNamedLambda (Id.of_string "Y") (mkFullInd ind (nb_ind-1+2)) (
- mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))),
- !eff
- in (* build_beq_scheme *)
- let names = Array.make nb_ind Anonymous and
- types = Array.make nb_ind mkSet and
- cores = Array.make nb_ind mkSet in
- let eff = ref Safe_typing.empty_private_constants in
- let u = Univ.Instance.empty in
- for i=0 to (nb_ind-1) do
- names.(i) <- Name (Id.of_string (rec_name i));
- types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0)
- (mkArrow (mkFullInd ((kn,i),u) 1) (Lazy.force bb));
- let c, eff' = make_one_eq i in
- cores.(i) <- c;
- eff := Safe_typing.concat_private eff' !eff
- done;
- (Array.init nb_ind (fun i ->
- let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in
- if not (Sorts.List.mem InSet kelim) then
- raise (NonSingletonProp (kn,i));
- let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in
- create_input fix),
- Evd.make_evar_universe_context (Global.env ()) None),
- !eff
-
-let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme
-
-let _ = beq_scheme_kind_aux := fun () -> beq_scheme_kind
-
-(* This function tryies to get the [inductive] between a constr
- the constr should be Ind i or App(Ind i,[|args|])
-*)
-let destruct_ind c =
- try let u,v = destApp c in
- let indc = destInd u in
- indc,v
- with DestKO -> let indc = destInd c in
- indc,[||]
-
-(*
- In the following, avoid is the list of names to avoid.
- If the args of the Inductive type are A1 ... An
- then avoid should be
- [| lb_An ... lb _A1 (resp. bl_An ... bl_A1)
- eq_An .... eq_A1 An ... A1 |]
-so from Ai we can find the the correct eq_Ai bl_ai or lb_ai
-*)
-(* used in the leib -> bool side*)
-let do_replace_lb mode lb_scheme_key aavoid narg p q =
- let avoid = Array.of_list aavoid in
- let do_arg v offset =
- try
- let x = narg*offset in
- let s = destVar v in
- let n = Array.length avoid in
- let rec find i =
- if Id.equal avoid.(n-i) s then avoid.(n-i-x)
- else (if i<n then find (i+1)
- else errorlabstrm "AutoIndDecl.do_replace_lb"
- (str "Var " ++ pr_id s ++ str " seems unknown.")
- )
- in mkVar (find 1)
- with e when CErrors.noncritical e ->
- (* if this happen then the args have to be already declared as a
- Parameter*)
- (
- let mp,dir,lbl = repr_con (fst (destConst v)) in
- mkConst (make_con mp dir (mk_label (
- if Int.equal offset 1 then ("eq_"^(Label.to_string lbl))
- else ((Label.to_string lbl)^"_lb")
- )))
- )
- in
- Proofview.Goal.nf_enter { enter = begin fun gl ->
- let type_of_pq = Tacmach.New.of_old (fun gl -> pf_unsafe_type_of gl p) gl in
- let u,v = destruct_ind type_of_pq
- in let lb_type_of_p =
- try
- let c, eff = find_scheme ~mode lb_scheme_key (out_punivs u) (*FIXME*) in
- Proofview.tclUNIT (mkConst c, eff)
- with Not_found ->
- (* spiwack: the format of this error message should probably
- be improved. *)
- let err_msg =
- (str "Leibniz->boolean:" ++
- str "You have to declare the" ++
- str "decidability over " ++
- Printer.pr_constr type_of_pq ++
- str " first.")
- in
- Tacticals.New.tclZEROMSG err_msg
- in
- lb_type_of_p >>= fun (lb_type_of_p,eff) ->
- let lb_args = Array.append (Array.append
- (Array.map (fun x -> x) v)
- (Array.map (fun x -> do_arg x 1) v))
- (Array.map (fun x -> do_arg x 2) v)
- in let app = if Array.equal eq_constr lb_args [||]
- then lb_type_of_p else mkApp (lb_type_of_p,lb_args)
- in
- Tacticals.New.tclTHENLIST [
- Proofview.tclEFFECTS eff;
- Equality.replace p q ; apply app ; Auto.default_auto]
- end }
-
-(* used in the bool -> leib side *)
-let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
- let avoid = Array.of_list aavoid in
- let do_arg v offset =
- try
- let x = narg*offset in
- let s = destVar v in
- let n = Array.length avoid in
- let rec find i =
- if Id.equal avoid.(n-i) s then avoid.(n-i-x)
- else (if i<n then find (i+1)
- else errorlabstrm "AutoIndDecl.do_replace_bl"
- (str "Var " ++ pr_id s ++ str " seems unknown.")
- )
- in mkVar (find 1)
- with e when CErrors.noncritical e ->
- (* if this happen then the args have to be already declared as a
- Parameter*)
- (
- let mp,dir,lbl = repr_con (fst (destConst v)) in
- mkConst (make_con mp dir (mk_label (
- if Int.equal offset 1 then ("eq_"^(Label.to_string lbl))
- else ((Label.to_string lbl)^"_bl")
- )))
- )
- in
-
- let rec aux l1 l2 =
- match (l1,l2) with
- | (t1::q1,t2::q2) ->
- Proofview.Goal.enter { enter = begin fun gl ->
- let tt1 = Tacmach.New.pf_unsafe_type_of gl t1 in
- if eq_constr t1 t2 then aux q1 q2
- else (
- let u,v = try destruct_ind tt1
- (* trick so that the good sequence is returned*)
- with e when CErrors.noncritical e -> indu,[||]
- in if eq_ind (fst u) ind
- then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ]
- else (
- let bl_t1, eff =
- try
- let c, eff = find_scheme bl_scheme_key (out_punivs u) (*FIXME*) in
- mkConst c, eff
- with Not_found ->
- (* spiwack: the format of this error message should probably
- be improved. *)
- let err_msg = string_of_ppcmds
- (str "boolean->Leibniz:" ++
- str "You have to declare the" ++
- str "decidability over " ++
- Printer.pr_constr tt1 ++
- str " first.")
- in
- error err_msg
- in let bl_args =
- Array.append (Array.append
- (Array.map (fun x -> x) v)
- (Array.map (fun x -> do_arg x 1) v))
- (Array.map (fun x -> do_arg x 2) v )
- in
- let app = if Array.equal eq_constr bl_args [||]
- then bl_t1 else mkApp (bl_t1,bl_args)
- in
- Tacticals.New.tclTHENLIST [
- Proofview.tclEFFECTS eff;
- Equality.replace_by t1 t2
- (Tacticals.New.tclTHEN (apply app) (Auto.default_auto)) ;
- aux q1 q2 ]
- )
- )
- end }
- | ([],[]) -> Proofview.tclUNIT ()
- | _ -> Tacticals.New.tclZEROMSG (str "Both side of the equality must have the same arity.")
- in
- begin try Proofview.tclUNIT (destApp lft)
- with DestKO -> Tacticals.New.tclZEROMSG (str "replace failed.")
- end >>= fun (ind1,ca1) ->
- begin try Proofview.tclUNIT (destApp rgt)
- with DestKO -> Tacticals.New.tclZEROMSG (str "replace failed.")
- end >>= fun (ind2,ca2) ->
- begin try Proofview.tclUNIT (out_punivs (destInd ind1))
- with DestKO ->
- begin try Proofview.tclUNIT (fst (fst (destConstruct ind1)))
- with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.")
- end
- end >>= fun (sp1,i1) ->
- begin try Proofview.tclUNIT (out_punivs (destInd ind2))
- with DestKO ->
- begin try Proofview.tclUNIT (fst (fst (destConstruct ind2)))
- with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.")
- end
- end >>= fun (sp2,i2) ->
- if not (eq_mind sp1 sp2) || not (Int.equal i1 i2)
- then Tacticals.New.tclZEROMSG (str "Eq should be on the same type")
- else aux (Array.to_list ca1) (Array.to_list ca2)
-
-(*
- create, from a list of ids [i1,i2,...,in] the list
- [(in,eq_in,in_bl,in_al),,...,(i1,eq_i1,i1_bl_i1_al )]
-*)
-let list_id l = List.fold_left ( fun a decl -> let s' =
- match get_name decl with
- Name s -> Id.to_string s
- | Anonymous -> "A" in
- (Id.of_string s',Id.of_string ("eq_"^s'),
- Id.of_string (s'^"_bl"),
- Id.of_string (s'^"_lb"))
- ::a
- ) [] l
-(*
- build the right eq_I A B.. N eq_A .. eq_N
-*)
-let eqI ind l =
- let list_id = list_id l in
- let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@
- (List.map (fun (_,seq,_,_)-> mkVar seq) list_id ))
- and e, eff =
- try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff
- with Not_found -> errorlabstrm "AutoIndDecl.eqI"
- (str "The boolean equality on " ++ pr_mind (fst ind) ++ str " is needed.");
- in (if Array.equal eq_constr eA [||] then e else mkApp(e,eA)), eff
-
-(**********************************************************************)
-(* Boolean->Leibniz *)
-
-let compute_bl_goal ind lnamesparrec nparrec =
- let eqI, eff = eqI ind lnamesparrec in
- let list_id = list_id lnamesparrec in
- let create_input c =
- let x = Id.of_string "x" and
- y = Id.of_string "y" in
- let bl_typ = List.map (fun (s,seq,_,_) ->
- mkNamedProd x (mkVar s) (
- mkNamedProd y (mkVar s) (
- mkArrow
- ( mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(mkVar seq,[|mkVar x;mkVar y|]);(Lazy.force tt)|]))
- ( mkApp(Lazy.force eq,[|mkVar s;mkVar x;mkVar y|]))
- ))
- ) list_id in
- let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b ->
- mkNamedProd sbl b a
- ) c (List.rev list_id) (List.rev bl_typ) in
- let eqs_typ = List.map (fun (s,_,_,_) ->
- mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(Lazy.force bb)))
- ) list_id in
- let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b ->
- mkNamedProd seq b a
- ) bl_input (List.rev list_id) (List.rev eqs_typ) in
- List.fold_left (fun a decl -> mkNamedProd
- (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A")
- (get_type decl) a) eq_input lnamesparrec
- in
- let n = Id.of_string "x" and
- m = Id.of_string "y" in
- let u = Univ.Instance.empty in
- create_input (
- mkNamedProd n (mkFullInd (ind,u) nparrec) (
- mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) (
- mkArrow
- (mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(eqI,[|mkVar n;mkVar m|]);(Lazy.force tt)|]))
- (mkApp(Lazy.force eq,[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|]))
- ))), eff
-
-let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec =
- let list_id = list_id lnamesparrec in
- let avoid = ref [] in
- let first_intros =
- ( List.map (fun (s,_,_,_) -> s ) list_id ) @
- ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @
- ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id )
- in
- let fresh_id s gl =
- Tacmach.New.of_old begin fun gsig ->
- let fresh = fresh_id (!avoid) s gsig in
- avoid := fresh::(!avoid); fresh
- end gl
- in
- Proofview.Goal.nf_enter { enter = begin fun gl ->
- let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
- let freshn = fresh_id (Id.of_string "x") gl in
- let freshm = fresh_id (Id.of_string "y") gl in
- let freshz = fresh_id (Id.of_string "Z") gl in
- (* try with *)
- Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros;
- intro_using freshn ;
- induct_on (mkVar freshn);
- intro_using freshm;
- destruct_on (mkVar freshm);
- intro_using freshz;
- intros;
- Tacticals.New.tclTRY (
- Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None)
- );
- simpl_in_hyp (freshz,Locus.InHyp);
-(*
-repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
-*)
- Tacticals.New.tclREPEAT (
- Tacticals.New.tclTHENLIST [
- Simple.apply_in freshz (andb_prop());
- Proofview.Goal.nf_enter { enter = begin fun gl ->
- let fresht = fresh_id (Id.of_string "Z") gl in
- destruct_on_as (mkVar freshz)
- (IntroOrPattern [[dl,IntroNaming (IntroIdentifier fresht);
- dl,IntroNaming (IntroIdentifier freshz)]])
- end }
- ]);
-(*
- Ci a1 ... an = Ci b1 ... bn
- replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto
-*)
- Proofview.Goal.nf_enter { enter = begin fun gls ->
- let gl = Proofview.Goal.concl gls in
- match (kind_of_term gl) with
- | App (c,ca) -> (
- match (kind_of_term c) with
- | Ind (indeq, u) ->
- if eq_gr (IndRef indeq) Coqlib.glob_eq
- then
- Tacticals.New.tclTHEN
- (do_replace_bl mode bl_scheme_key ind
- (!avoid)
- nparrec (ca.(2))
- (ca.(1)))
- Auto.default_auto
- else
- Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.")
- | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.")
- )
- | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.")
- end }
-
- ]
- end }
-
-let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
-
-let side_effect_of_mode = function
- | Declare.UserAutomaticRequest -> false
- | Declare.InternalTacticRequest -> true
- | Declare.UserIndividualRequest -> false
-
-let make_bl_scheme mode mind =
- let mib = Global.lookup_mind mind in
- if not (Int.equal (Array.length mib.mind_packets) 1) then
- errorlabstrm ""
- (str "Automatic building of boolean->Leibniz lemmas not supported");
- let ind = (mind,0) in
- let nparams = mib.mind_nparams in
- let nparrec = mib.mind_nparams_rec in
- let lnonparrec,lnamesparrec = (* TODO subst *)
- context_chop (nparams-nparrec) mib.mind_params_ctxt in
- let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in
- let ctx = Evd.make_evar_universe_context (Global.env ()) None in
- let side_eff = side_effect_of_mode mode in
- let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx bl_goal
- (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec)
- in
- ([|ans|], ctx), eff
-
-let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme
-
-let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind
-
-(**********************************************************************)
-(* Leibniz->Boolean *)
-
-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 eqI, eff = eqI ind lnamesparrec in
- let create_input c =
- let x = Id.of_string "x" and
- y = Id.of_string "y" in
- let lb_typ = List.map (fun (s,seq,_,_) ->
- mkNamedProd x (mkVar s) (
- mkNamedProd y (mkVar s) (
- mkArrow
- ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
- ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
- ))
- ) list_id in
- let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b ->
- mkNamedProd slb b a
- ) c (List.rev list_id) (List.rev lb_typ) in
- let eqs_typ = List.map (fun (s,_,_,_) ->
- mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb))
- ) list_id in
- let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b ->
- mkNamedProd seq b a
- ) lb_input (List.rev list_id) (List.rev eqs_typ) in
- List.fold_left (fun a decl -> mkNamedProd
- (match (get_name decl) with Name s -> s | Anonymous -> Id.of_string "A")
- (get_type decl) a) eq_input lnamesparrec
- in
- let n = Id.of_string "x" and
- m = Id.of_string "y" in
- let u = Univ.Instance.empty in
- create_input (
- mkNamedProd n (mkFullInd (ind,u) nparrec) (
- mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) (
- mkArrow
- (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|]))
- (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|]))
- ))), eff
-
-let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec =
- let list_id = list_id lnamesparrec in
- let avoid = ref [] in
- let first_intros =
- ( List.map (fun (s,_,_,_) -> s ) list_id ) @
- ( List.map (fun (_,seq,_,_) -> seq) list_id ) @
- ( List.map (fun (_,_,_,slb) -> slb) list_id )
- in
- let fresh_id s gl =
- Tacmach.New.of_old begin fun gsig ->
- let fresh = fresh_id (!avoid) s gsig in
- avoid := fresh::(!avoid); fresh
- end gl
- in
- Proofview.Goal.nf_enter { enter = begin fun gl ->
- let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
- let freshn = fresh_id (Id.of_string "x") gl in
- let freshm = fresh_id (Id.of_string "y") gl in
- let freshz = fresh_id (Id.of_string "Z") gl in
- (* try with *)
- Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros;
- intro_using freshn ;
- induct_on (mkVar freshn);
- intro_using freshm;
- destruct_on (mkVar freshm);
- intro_using freshz;
- intros;
- Tacticals.New.tclTRY (
- Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None)
- );
- Equality.inj None false None (mkVar freshz,NoBindings);
- intros; simpl_in_concl;
- Auto.default_auto;
- Tacticals.New.tclREPEAT (
- Tacticals.New.tclTHENLIST [apply (andb_true_intro());
- simplest_split ;Auto.default_auto ]
- );
- Proofview.Goal.nf_enter { enter = begin fun gls ->
- let gl = Proofview.Goal.concl gls in
- (* assume the goal to be eq (eq_type ...) = true *)
- match (kind_of_term gl) with
- | App(c,ca) -> (match (kind_of_term ca.(1)) with
- | App(c',ca') ->
- let n = Array.length ca' in
- do_replace_lb mode lb_scheme_key
- (!avoid)
- nparrec
- ca'.(n-2) ca'.(n-1)
- | _ ->
- Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.")
- )
- | _ ->
- Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.")
- end }
- ]
- end }
-
-let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined")
-
-let make_lb_scheme mode mind =
- let mib = Global.lookup_mind mind in
- if not (Int.equal (Array.length mib.mind_packets) 1) then
- errorlabstrm ""
- (str "Automatic building of Leibniz->boolean lemmas not supported");
- let ind = (mind,0) in
- let nparams = mib.mind_nparams in
- let nparrec = mib.mind_nparams_rec in
- let lnonparrec,lnamesparrec =
- context_chop (nparams-nparrec) mib.mind_params_ctxt in
- let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in
- let ctx = Evd.make_evar_universe_context (Global.env ()) None in
- let side_eff = side_effect_of_mode mode in
- let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx lb_goal
- (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec)
- in
- ([|ans|], ctx), eff
-
-let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme
-
-let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind
-
-(**********************************************************************)
-(* Decidable equality *)
-
-let check_not_is_defined () =
- try ignore (Coqlib.build_coq_not ())
- with e when CErrors.noncritical e -> raise (UndefinedCst "not")
-
-(* {n=m}+{n<>m} part *)
-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 create_input c =
- let x = Id.of_string "x" and
- y = Id.of_string "y" in
- let lb_typ = List.map (fun (s,seq,_,_) ->
- mkNamedProd x (mkVar s) (
- mkNamedProd y (mkVar s) (
- mkArrow
- ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
- ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
- ))
- ) list_id in
- let bl_typ = List.map (fun (s,seq,_,_) ->
- mkNamedProd x (mkVar s) (
- mkNamedProd y (mkVar s) (
- mkArrow
- ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
- ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
- ))
- ) list_id in
-
- let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b ->
- mkNamedProd slb b a
- ) c (List.rev list_id) (List.rev lb_typ) in
- let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b ->
- mkNamedProd sbl b a
- ) lb_input (List.rev list_id) (List.rev bl_typ) in
-
- let eqs_typ = List.map (fun (s,_,_,_) ->
- mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb))
- ) list_id in
- let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b ->
- mkNamedProd seq b a
- ) bl_input (List.rev list_id) (List.rev eqs_typ) in
- List.fold_left (fun a decl -> mkNamedProd
- (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A")
- (get_type decl) a) eq_input lnamesparrec
- in
- let n = Id.of_string "x" and
- m = Id.of_string "y" in
- let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in
- create_input (
- mkNamedProd n (mkFullInd ind (2*nparrec)) (
- mkNamedProd m (mkFullInd ind (2*nparrec+1)) (
- mkApp(sumbool(),[|eqnm;mkApp (Coqlib.build_coq_not(),[|eqnm|])|])
- )
- )
- )
-
-let compute_dec_tact ind lnamesparrec nparrec =
- let eq = Lazy.force eq and tt = Lazy.force tt
- and ff = Lazy.force ff and bb = Lazy.force bb in
- let list_id = list_id lnamesparrec in
- let eqI, eff = eqI ind lnamesparrec in
- let avoid = ref [] in
- let eqtrue x = mkApp(eq,[|bb;x;tt|]) in
- let eqfalse x = mkApp(eq,[|bb;x;ff|]) in
- let first_intros =
- ( List.map (fun (s,_,_,_) -> s ) list_id ) @
- ( List.map (fun (_,seq,_,_) -> seq) list_id ) @
- ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @
- ( List.map (fun (_,_,_,slb) -> slb) list_id )
- in
- let fresh_id s gl =
- Tacmach.New.of_old begin fun gsig ->
- let fresh = fresh_id (!avoid) s gsig in
- avoid := fresh::(!avoid); fresh
- end gl
- in
- Proofview.Goal.nf_enter { enter = begin fun gl ->
- let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
- let freshn = fresh_id (Id.of_string "x") gl in
- let freshm = fresh_id (Id.of_string "y") gl in
- let freshH = fresh_id (Id.of_string "H") gl in
- let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in
- let arfresh = Array.of_list fresh_first_intros in
- let xargs = Array.sub arfresh 0 (2*nparrec) in
- begin try
- let c, eff = find_scheme bl_scheme_kind ind in
- Proofview.tclUNIT (mkConst c,eff) with
- Not_found ->
- Tacticals.New.tclZEROMSG (str "Error during the decidability part, boolean to leibniz equality is required.")
- end >>= fun (blI,eff') ->
- begin try
- let c, eff = find_scheme lb_scheme_kind ind in
- Proofview.tclUNIT (mkConst c,eff) with
- Not_found ->
- Tacticals.New.tclZEROMSG (str "Error during the decidability part, leibniz to boolean equality is required.")
- end >>= fun (lbI,eff'') ->
- let eff = (Safe_typing.concat_private eff'' (Safe_typing.concat_private eff' eff)) in
- Tacticals.New.tclTHENLIST [
- Proofview.tclEFFECTS eff;
- intros_using fresh_first_intros;
- intros_using [freshn;freshm];
- (*we do this so we don't have to prove the same goal twice *)
- assert_by (Name freshH) (
- mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|])
- )
- (Tacticals.New.tclTHEN (destruct_on eqbnm) Auto.default_auto);
-
- Proofview.Goal.nf_enter { enter = begin fun gl ->
- let freshH2 = fresh_id (Id.of_string "H") gl in
- Tacticals.New.tclTHENS (destruct_on_using (mkVar freshH) freshH2) [
- (* left *)
- Tacticals.New.tclTHENLIST [
- simplest_left;
- apply (mkApp(blI,Array.map(fun x->mkVar x) xargs));
- Auto.default_auto
- ]
- ;
-
- (*right *)
- Proofview.Goal.nf_enter { enter = begin fun gl ->
- let freshH3 = fresh_id (Id.of_string "H") gl in
- Tacticals.New.tclTHENLIST [
- simplest_right ;
- unfold_constr (Lazy.force Coqlib.coq_not_ref);
- intro;
- Equality.subst_all ();
- assert_by (Name freshH3)
- (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))
- (Tacticals.New.tclTHENLIST [
- apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs));
- Auto.default_auto
- ]);
- Equality.general_rewrite_bindings_in true
- Locus.AllOccurrences true false
- (List.hd !avoid)
- ((mkVar (List.hd (List.tl !avoid))),
- NoBindings
- )
- true;
- Equality.discr_tac false None
- ]
- end }
- ]
- end }
- ]
- end }
-
-let make_eq_decidability mode mind =
- let mib = Global.lookup_mind mind in
- if not (Int.equal (Array.length mib.mind_packets) 1) then
- raise DecidabilityMutualNotSupported;
- let ind = (mind,0) in
- let nparams = mib.mind_nparams in
- let nparrec = mib.mind_nparams_rec in
- let u = Univ.Instance.empty in
- let ctx = Evd.make_evar_universe_context (Global.env ()) None in
- let lnonparrec,lnamesparrec =
- context_chop (nparams-nparrec) mib.mind_params_ctxt in
- let side_eff = side_effect_of_mode mode in
- let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx
- (compute_dec_goal (ind,u) lnamesparrec nparrec)
- (compute_dec_tact ind lnamesparrec nparrec)
- in
- ([|ans|], ctx), Safe_typing.empty_private_constants
-
-let eq_dec_scheme_kind =
- declare_mutual_scheme_object "_eq_dec" make_eq_decidability
-
-(* The eq_dec_scheme proofs depend on the equality and discr tactics
- but the inj tactics, that comes with discr, depends on the
- eq_dec_scheme... *)
-
-let _ = Equality.set_eq_dec_scheme_kind eq_dec_scheme_kind
diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli
deleted file mode 100644
index fa5c6148..00000000
--- a/toplevel/auto_ind_decl.mli
+++ /dev/null
@@ -1,41 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open Ind_tables
-
-(** This file is about the automatic generation of schemes about
- decidable equality,
- @author Vincent Siles
- Oct 2007 *)
-
-(** {6 Build boolean equality of a block of mutual inductive types } *)
-
-exception EqNotFound of inductive * inductive
-exception EqUnknown of string
-exception UndefinedCst of string
-exception InductiveWithProduct
-exception InductiveWithSort
-exception ParameterWithoutEquality of Globnames.global_reference
-exception NonSingletonProp of inductive
-exception DecidabilityMutualNotSupported
-
-val beq_scheme_kind : mutual scheme_kind
-val build_beq_scheme : mutual_scheme_object_function
-
-(** {6 Build equivalence between boolean equality and Leibniz equality } *)
-
-val lb_scheme_kind : mutual scheme_kind
-val make_lb_scheme : mutual_scheme_object_function
-val bl_scheme_kind : mutual scheme_kind
-val make_bl_scheme : mutual_scheme_object_function
-
-(** {6 Build decidability of equality } *)
-
-val eq_dec_scheme_kind : mutual scheme_kind
-val make_eq_decidability : mutual_scheme_object_function
diff --git a/toplevel/class.ml b/toplevel/class.ml
deleted file mode 100644
index 6d53ec9d..00000000
--- a/toplevel/class.ml
+++ /dev/null
@@ -1,328 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open CErrors
-open Util
-open Pp
-open Names
-open Term
-open Vars
-open Termops
-open Entries
-open Environ
-open Classops
-open Declare
-open Globnames
-open Nametab
-open Decl_kinds
-
-let strength_min l = if List.mem `LOCAL l then `LOCAL else `GLOBAL
-
-let loc_of_bool b = if b then `LOCAL else `GLOBAL
-
-(* Errors *)
-
-type coercion_error_kind =
- | AlreadyExists
- | NotAFunction
- | NoSource of cl_typ option
- | ForbiddenSourceClass of cl_typ
- | NoTarget
- | WrongTarget of cl_typ * cl_typ
- | NotAClass of global_reference
-
-exception CoercionError of coercion_error_kind
-
-let explain_coercion_error g = function
- | AlreadyExists ->
- (Printer.pr_global g ++ str" is already a coercion")
- | NotAFunction ->
- (Printer.pr_global g ++ str" is not a function")
- | NoSource (Some cl) ->
- (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of "
- ++ Printer.pr_global g)
- | NoSource None ->
- (str ": cannot find the source class of " ++ Printer.pr_global g)
- | ForbiddenSourceClass cl ->
- pr_class cl ++ str " cannot be a source class"
- | NoTarget ->
- (str"Cannot find the target class")
- | WrongTarget (clt,cl) ->
- (str"Found target class " ++ pr_class cl ++
- str " instead of " ++ pr_class clt)
- | NotAClass ref ->
- (str "Type of " ++ Printer.pr_global ref ++
- str " does not end with a sort")
-
-(* Verifications pour l'ajout d'une classe *)
-
-let check_reference_arity ref =
- if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global_unsafe ref)) then
- raise (CoercionError (NotAClass ref))
-
-let check_arity = function
- | CL_FUN | CL_SORT -> ()
- | CL_CONST cst -> check_reference_arity (ConstRef cst)
- | CL_PROJ cst -> check_reference_arity (ConstRef cst)
- | CL_SECVAR id -> check_reference_arity (VarRef id)
- | CL_IND kn -> check_reference_arity (IndRef kn)
-
-(* Coercions *)
-
-(* check that the computed target is the provided one *)
-let check_target clt = function
- | Some cl when not (cl_typ_eq cl clt) -> raise (CoercionError (WrongTarget(clt,cl)))
- | _ -> ()
-
-(* condition d'heritage uniforme *)
-
-let uniform_cond nargs lt =
- let rec aux = function
- | (0,[]) -> true
- | (n,t::l) ->
- let t = strip_outer_cast t in
- isRel t && Int.equal (destRel t) n && aux ((n-1),l)
- | _ -> false
- in
- aux (nargs,lt)
-
-let class_of_global = function
- | ConstRef sp ->
- if Environ.is_projection sp (Global.env ())
- then CL_PROJ sp else CL_CONST sp
- | IndRef sp -> CL_IND sp
- | VarRef id -> CL_SECVAR id
- | ConstructRef _ as c ->
- errorlabstrm "class_of_global"
- (str "Constructors, such as " ++ Printer.pr_global c ++
- str ", cannot be used as a class.")
-
-(*
-lp est la liste (inverse'e) des arguments de la coercion
-ids est le nom de la classe source
-sps_opt est le sp de la classe source dans le cas des structures
-retourne:
-la classe source
-nbre d'arguments de la classe
-le constr de la class
-la liste des variables dont depend la classe source
-l'indice de la classe source dans la liste lp
-*)
-
-let get_source lp source =
- match source with
- | None ->
- let (cl1,u1,lv1) =
- match lp with
- | [] -> raise Not_found
- | t1::_ -> find_class_type Evd.empty t1
- in
- (cl1,u1,lv1,1)
- | Some cl ->
- let rec aux = function
- | [] -> raise Not_found
- | t1::lt ->
- try
- let cl1,u1,lv1 = find_class_type Evd.empty t1 in
- if cl_typ_eq cl cl1 then cl1,u1,lv1,(List.length lt+1)
- else raise Not_found
- with Not_found -> aux lt
- in aux (List.rev lp)
-
-let get_target t ind =
- if (ind > 1) then
- CL_FUN
- else
- match pi1 (find_class_type Evd.empty t) with
- | CL_CONST p when Environ.is_projection p (Global.env ()) ->
- CL_PROJ p
- | x -> x
-
-
-let prods_of t =
- let rec aux acc d = match kind_of_term d with
- | Prod (_,c1,c2) -> aux (c1::acc) c2
- | Cast (c,_,_) -> aux acc c
- | _ -> (d,acc)
- in
- aux [] t
-
-let strength_of_cl = function
- | CL_CONST kn -> `GLOBAL
- | CL_SECVAR id -> `LOCAL
- | _ -> `GLOBAL
-
-let strength_of_global = function
- | VarRef _ -> `LOCAL
- | _ -> `GLOBAL
-
-let get_strength stre ref cls clt =
- let stres = strength_of_cl cls in
- let stret = strength_of_cl clt in
- let stref = strength_of_global ref in
- strength_min [stre;stres;stret;stref]
-
-let ident_key_of_class = function
- | CL_FUN -> "Funclass"
- | CL_SORT -> "Sortclass"
- | CL_CONST sp | CL_PROJ sp -> Label.to_string (con_label sp)
- | CL_IND (sp,_) -> Label.to_string (mind_label sp)
- | CL_SECVAR id -> Id.to_string id
-
-(* Identity coercion *)
-
-let error_not_transparent source =
- errorlabstrm "build_id_coercion"
- (pr_class source ++ str " must be a transparent constant.")
-
-let build_id_coercion idf_opt source poly =
- let env = Global.env () in
- let sigma = Evd.from_env env in
- let sigma, vs = match source with
- | CL_CONST sp -> Evd.fresh_global env sigma (ConstRef sp)
- | _ -> error_not_transparent source in
- let c = match constant_opt_value_in env (destConst vs) with
- | Some c -> c
- | None -> error_not_transparent source in
- let lams,t = decompose_lam_assum c in
- let val_f =
- it_mkLambda_or_LetIn
- (mkLambda (Name Namegen.default_dependent_ident,
- applistc vs (Context.Rel.to_extended_list 0 lams),
- mkRel 1))
- lams
- in
- let typ_f =
- it_mkProd_wo_LetIn
- (mkProd (Anonymous, applistc vs (Context.Rel.to_extended_list 0 lams), lift 1 t))
- lams
- in
- (* juste pour verification *)
- let _ =
- if not
- (Reductionops.is_conv_leq env sigma
- (Typing.unsafe_type_of env sigma val_f) typ_f)
- then
- errorlabstrm "" (strbrk
- "Cannot be defined as coercion (maybe a bad number of arguments).")
- in
- let idf =
- match idf_opt with
- | Some idf -> idf
- | None ->
- let cl,u,_ = find_class_type sigma t in
- Id.of_string ("Id_"^(ident_key_of_class source)^"_"^
- (ident_key_of_class cl))
- 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))
- ~inline:true (mkCast (val_f, DEFAULTcast, typ_f)))
- in
- let decl = (constr_entry, IsDefinition IdentityCoercion) in
- let kn = declare_constant idf decl in
- ConstRef kn
-
-let check_source = function
-| Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s))
-| _ -> ()
-
-(*
-nom de la fonction coercion
-strength de f
-nom de la classe source (optionnel)
-sp de la classe source (dans le cas des structures)
-nom de la classe target (optionnel)
-booleen "coercion identite'?"
-
-lorque source est None alors target est None aussi.
-*)
-
-let warn_uniform_inheritance =
- CWarnings.create ~name:"uniform-inheritance" ~category:"typechecker"
- (fun g ->
- Printer.pr_global g ++
- strbrk" does not respect the uniform inheritance condition")
-
-let add_new_coercion_core coef stre poly source target isid =
- check_source source;
- let t = Global.type_of_global_unsafe coef in
- if coercion_exists coef then raise (CoercionError AlreadyExists);
- let tg,lp = prods_of t in
- let llp = List.length lp in
- if Int.equal llp 0 then raise (CoercionError NotAFunction);
- let (cls,us,lvs,ind) =
- try
- get_source lp source
- with Not_found ->
- raise (CoercionError (NoSource source))
- in
- check_source (Some cls);
- if not (uniform_cond (llp-ind) lvs) then
- warn_uniform_inheritance coef;
- let clt =
- try
- get_target tg ind
- with Not_found ->
- raise (CoercionError NoTarget)
- in
- check_target clt target;
- check_arity cls;
- check_arity clt;
- let local = match get_strength stre coef cls clt with
- | `LOCAL -> true
- | `GLOBAL -> false
- in
- declare_coercion coef ~local ~isid ~src:cls ~target:clt ~params:(List.length lvs)
-
-
-let try_add_new_coercion_core ref ~local c d e f =
- try add_new_coercion_core ref (loc_of_bool local) c d e f
- with CoercionError e ->
- errorlabstrm "try_add_new_coercion_core"
- (explain_coercion_error ref e ++ str ".")
-
-let try_add_new_coercion ref ~local poly =
- try_add_new_coercion_core ref ~local poly None None false
-
-let try_add_new_coercion_subclass cl ~local poly =
- let coe_ref = build_id_coercion None cl poly in
- try_add_new_coercion_core coe_ref ~local poly (Some cl) None true
-
-let try_add_new_coercion_with_target ref ~local poly ~source ~target =
- try_add_new_coercion_core ref ~local poly (Some source) (Some target) false
-
-let try_add_new_identity_coercion id ~local poly ~source ~target =
- let ref = build_id_coercion (Some id) source poly in
- try_add_new_coercion_core ref ~local poly (Some source) (Some target) true
-
-let try_add_new_coercion_with_source ref ~local poly ~source =
- try_add_new_coercion_core ref ~local poly (Some source) None false
-
-let add_coercion_hook poly local ref =
- let stre = match local with
- | Local -> true
- | Global -> false
- | Discharge -> assert false
- in
- let () = try_add_new_coercion ref stre poly in
- let msg = pr_global_env Id.Set.empty ref ++ str " is now a coercion" in
- Flags.if_verbose Feedback.msg_info msg
-
-let add_coercion_hook poly = Lemmas.mk_hook (add_coercion_hook poly)
-
-let add_subclass_hook poly local ref =
- let stre = match local with
- | Local -> true
- | Global -> false
- | Discharge -> assert false
- in
- let cl = class_of_global ref in
- try_add_new_coercion_subclass cl stre poly
-
-let add_subclass_hook poly = Lemmas.mk_hook (add_subclass_hook poly)
diff --git a/toplevel/class.mli b/toplevel/class.mli
deleted file mode 100644
index 5f9ae28f..00000000
--- a/toplevel/class.mli
+++ /dev/null
@@ -1,48 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open Classops
-open Globnames
-
-(** Classes and coercions. *)
-
-(** [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion
- from [src] to [tg] *)
-val try_add_new_coercion_with_target : global_reference -> local:bool ->
- Decl_kinds.polymorphic ->
- source:cl_typ -> target:cl_typ -> unit
-
-(** [try_add_new_coercion ref s] declares [ref], assumed to be of type
- [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *)
-val try_add_new_coercion : global_reference -> local:bool ->
- Decl_kinds.polymorphic -> unit
-
-(** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a
- transparent constant which unfolds to some class [tg]; it declares
- an identity coercion from [cst] to [tg], named something like
- ["Id_cst_tg"] *)
-val try_add_new_coercion_subclass : cl_typ -> local:bool ->
- Decl_kinds.polymorphic -> unit
-
-(** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion
- from [src] to [tg] where the target is inferred from the type of [ref] *)
-val try_add_new_coercion_with_source : global_reference -> local:bool ->
- Decl_kinds.polymorphic -> source:cl_typ -> unit
-
-(** [try_add_new_identity_coercion id s src tg] enriches the
- environment with a new definition of name [id] declared as an
- identity coercion from [src] to [tg] *)
-val try_add_new_identity_coercion : Id.t -> local:bool ->
- Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit
-
-val add_coercion_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook
-
-val add_subclass_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook
-
-val class_of_global : global_reference -> cl_typ
diff --git a/toplevel/classes.ml b/toplevel/classes.ml
deleted file mode 100644
index 1528cbb2..00000000
--- a/toplevel/classes.ml
+++ /dev/null
@@ -1,408 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(*i*)
-open Names
-open Term
-open Vars
-open Environ
-open Nametab
-open CErrors
-open Util
-open Typeclasses_errors
-open Typeclasses
-open Libnames
-open Globnames
-open Constrintern
-open Constrexpr
-open Sigma.Notations
-open Context.Rel.Declaration
-(*i*)
-
-open Decl_kinds
-open Entries
-
-let refine_instance = ref true
-
-let _ = Goptions.declare_bool_option {
- Goptions.optsync = true;
- Goptions.optdepr = false;
- Goptions.optname = "definition of instances by refining";
- Goptions.optkey = ["Refine";"Instance";"Mode"];
- Goptions.optread = (fun () -> !refine_instance);
- Goptions.optwrite = (fun b -> refine_instance := b)
-}
-
-let typeclasses_db = "typeclass_instances"
-
-let set_typeclass_transparency c local b =
- Hints.add_hints local [typeclasses_db]
- (Hints.HintsTransparencyEntry ([c], b))
-
-let _ =
- Hook.set Typeclasses.add_instance_hint_hook
- (fun inst path local info poly ->
- let inst' = match inst with IsConstr c -> Hints.IsConstr (c, Univ.ContextSet.empty)
- | IsGlobal gr -> Hints.IsGlobRef gr
- in
- let info =
- let open Vernacexpr in
- { info with hint_pattern =
- Option.map
- (Constrintern.intern_constr_pattern (Global.env()))
- info.hint_pattern } in
- Flags.silently (fun () ->
- Hints.add_hints local [typeclasses_db]
- (Hints.HintsResolveEntry
- [info, poly, false, Hints.PathHints path, inst'])) ());
- Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency;
- Hook.set Typeclasses.classes_transparent_state_hook
- (fun () -> Hints.Hint_db.transparent_state (Hints.searchtable_map typeclasses_db))
-
-open Vernacexpr
-
-(** TODO: add subinstances *)
-let existing_instance glob g info =
- let c = global g in
- let info = Option.default Hints.empty_hint_info info in
- let instance = Global.type_of_global_unsafe c in
- let _, r = decompose_prod_assum instance in
- match class_of_constr r with
- | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob
- (*FIXME*) (Flags.use_polymorphic_flag ()) c)
- | None -> user_err_loc (loc_of_reference g, "declare_instance",
- Pp.str "Constant does not build instances of a declared type class.")
-
-let mismatched_params env n m = mismatched_ctx_inst env Parameters n m
-let mismatched_props env n m = mismatched_ctx_inst env Properties n m
-
-(* Declare everything in the parameters as implicit, and the class instance as well *)
-
-let type_ctx_instance evars env ctx inst subst =
- let rec aux (subst, instctx) l = function
- decl :: ctx ->
- let t' = substl subst (get_type decl) in
- let c', l =
- match decl with
- | LocalAssum _ -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l
- | LocalDef (_,b,_) -> substl subst b, l
- in
- let d = get_name decl, Some c', t' in
- aux (c' :: subst, d :: instctx) l ctx
- | [] -> subst
- in aux (subst, []) inst (List.rev ctx)
-
-let id_of_class cl =
- match cl.cl_impl with
- | ConstRef kn -> let _,_,l = repr_con kn in Label.to_id l
- | IndRef (kn,i) ->
- let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in
- mip.(0).Declarations.mind_typename
- | _ -> assert false
-
-open Pp
-
-let instance_hook k info global imps ?hook cst =
- Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps;
- 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 kind = IsDefinition Instance in
- let evm =
- let levels = Univ.LSet.union (Universes.universes_of_constr termtype)
- (Universes.universes_of_constr term) in
- Evd.restrict_universe_context evm levels
- in
- let pl, uctx = Evd.universe_context ?names:pl evm in
- let entry =
- Declare.definition_entry ~types:termtype ~poly ~univs:uctx term
- in
- let cdecl = (DefinitionEntry entry, kind) in
- let kn = Declare.declare_constant id cdecl in
- Declare.definition_message id;
- Universes.register_universe_binders (ConstRef kn) pl;
- 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 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 tclass, ids =
- match bk with
- | Decl_kinds.Implicit ->
- Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false
- (fun avoid (clname, _) ->
- match clname with
- | Some (cl, b) ->
- let t = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in
- t, avoid
- | None -> failwith ("new instance: under-applied typeclass"))
- cl
- | Explicit -> cl, Id.Set.empty
- in
- let tclass =
- if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass)
- else tclass
- in
- let k, u, cty, ctx', ctx, len, imps, subst =
- let impls, ((env', ctx), imps) = interp_context_evars env evars ctx in
- let c', imps' = interp_type_evars_impls ~impls env' evars tclass in
- let len = List.length ctx in
- let imps = imps @ Impargs.lift_implicits len imps' in
- let ctx', c = decompose_prod_assum c' in
- let ctx'' = ctx' @ ctx in
- let k, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in
- let cl, u = Typeclasses.typeclass_univ_instance k in
- let _, args =
- List.fold_right (fun decl (args, args') ->
- let open Context.Rel.Declaration in
- match decl with
- | LocalAssum _ -> (List.tl args, List.hd args :: args')
- | LocalDef (_,b,_) -> (args, substl args' b :: args'))
- (snd cl.cl_context) (args, [])
- in
- cl, u, c', ctx', ctx, len, imps, args
- in
- let id =
- match instid with
- Name id ->
- let sp = Lib.make_path id in
- if Nametab.exists_cci sp then
- errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists.");
- 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)
- in
- let env' = push_rel_context ctx env in
- evars := Evarutil.nf_evar_map !evars;
- evars := resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env !evars;
- let subst = List.map (Evarutil.nf_evar !evars) subst in
- if abstract then
- begin
- let subst = List.fold_left2
- (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst')
- [] subst (snd k.cl_context)
- in
- let (_, ty_constr) = instance_constructor (k,u) subst in
- let nf, subst = Evarutil.e_nf_evars_and_universes evars in
- let termtype =
- let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
- nf t
- in
- Pretyping.check_evars env Evd.empty !evars termtype;
- let pl, ctx = Evd.universe_context ?names:pl !evars in
- let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id
- (ParameterEntry
- (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical)
- in
- Universes.register_universe_binders (ConstRef cst) pl;
- instance_hook k pri global imps ?hook (ConstRef cst); id
- end
- else (
- let props =
- match props with
- | Some (true, CRecord (loc, fs)) ->
- if List.length fs > List.length k.cl_props then
- mismatched_props env' (List.map snd fs) k.cl_props;
- Some (Inl fs)
- | Some (_, t) -> Some (Inr t)
- | None ->
- if Flags.is_program_mode () then Some (Inl [])
- else None
- in
- let subst =
- match props with
- | None -> if List.is_empty k.cl_props then Some (Inl subst) else None
- | Some (Inr term) ->
- let c = interp_casted_constr_evars env' evars term cty in
- Some (Inr (c, subst))
- | Some (Inl props) ->
- let get_id =
- function
- | Ident id' -> id'
- | Qualid (loc,id') -> (loc, snd (repr_qualid id'))
- in
- let props, rest =
- List.fold_left
- (fun (props, rest) decl ->
- if is_local_assum decl then
- try
- let is_id (id', _) = match get_name decl, get_id id' with
- | Name id, (_, id') -> Id.equal id id'
- | Anonymous, _ -> false
- in
- let (loc_mid, c) =
- List.find is_id rest
- in
- let rest' =
- List.filter (fun v -> not (is_id v)) rest
- in
- let (loc, mid) = get_id loc_mid in
- List.iter (fun (n, _, x) ->
- if Name.equal n (Name mid) then
- Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x)
- k.cl_projs;
- c :: props, rest'
- with Not_found ->
- (CHole (Loc.ghost, None(* Some Evar_kinds.GoalEvar *), Misctypes.IntroAnonymous, None) :: props), rest
- else props, rest)
- ([], props) k.cl_props
- in
- match rest with
- | (n, _) :: _ ->
- unbound_method env' k.cl_impl (get_id n)
- | _ ->
- Some (Inl (type_ctx_instance evars (push_rel_context ctx' env')
- k.cl_props props subst))
- in
- let term, termtype =
- match subst with
- | None -> let termtype = it_mkProd_or_LetIn cty ctx in
- None, termtype
- | Some (Inl subst) ->
- let subst = List.fold_left2
- (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst')
- [] subst (k.cl_props @ snd k.cl_context)
- in
- let (app, ty_constr) = instance_constructor (k,u) subst in
- let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
- let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in
- Some term, termtype
- | Some (Inr (def, subst)) ->
- let termtype = it_mkProd_or_LetIn cty ctx in
- let term = Termops.it_mkLambda_or_LetIn def ctx in
- Some term, termtype
- in
- let _ =
- evars := Evarutil.nf_evar_map !evars;
- evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals_or_obligations ~fail:true
- env !evars;
- (* Try resolving fields that are typeclasses automatically. *)
- evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false
- env !evars
- in
- let _ = evars := Evarutil.nf_evar_map_undefined !evars in
- let evm, nf = Evarutil.nf_evar_map_universes !evars in
- let termtype = nf termtype in
- let _ = (* Check that the type is free of evars now. *)
- Pretyping.check_evars env Evd.empty evm termtype
- 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
- 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
- if Flags.is_program_mode () then
- let hook vis gr _ =
- let cst = match gr with ConstRef kn -> kn | _ -> assert false in
- Impargs.declare_manual_implicits false gr ~enriching:false [imps];
- Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst)
- in
- let obls, constr, typ =
- match term with
- | Some t ->
- let obls, _, constr, typ =
- Obligations.eterm_obligations env id evm 0 t termtype
- in obls, Some constr, typ
- | None -> [||], None, termtype
- in
- 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);
- id
- else
- (Flags.silently
- (fun () ->
- (* spiwack: it is hard to reorder the actions to do
- the pretyping after the proof has opened. As a
- consequence, we use the low-level primitives to code
- the refinement manually.*)
- let gls = List.rev (Evd.future_goals evm) in
- let evm = Evd.reset_future_goals evm in
- Lemmas.start_proof id kind evm termtype
- (Lemmas.mk_hook
- (fun _ -> instance_hook k pri global imps ?hook));
- (* spiwack: I don't know what to do with the status here. *)
- if not (Option.is_empty term) then
- let init_refine =
- Tacticals.New.tclTHENLIST [
- Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) };
- Proofview.Unsafe.tclNEWGOALS gls;
- Tactics.New.reduce_after_refine;
- ]
- in
- ignore (Pfedit.by init_refine)
- else if Flags.is_auto_intros () then
- ignore (Pfedit.by (Tacticals.New.tclDO len Tactics.intro));
- (match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) ();
- id)
- end
- else CErrors.error "Unsolved obligations remaining.")
-
-let named_of_rel_context l =
- let acc, ctx =
- List.fold_right
- (fun decl (subst, ctx) ->
- let id = match get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in
- let d = match decl with
- | LocalAssum (_,t) -> id, None, substl subst t
- | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in
- (mkVar id :: subst, d :: ctx))
- l ([], [])
- in ctx
-
-let context poly l =
- let env = Global.env() in
- let evars = ref (Evd.from_env env) in
- let _, ((env', fullctx), impls) = interp_context_evars env evars l in
- let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in
- let fullctx = Context.Rel.map subst fullctx in
- let ce t = Pretyping.check_evars env Evd.empty !evars t in
- let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in
- let ctx =
- try named_of_rel_context fullctx
- with e when CErrors.noncritical e ->
- error "Anonymous variables not allowed in contexts."
- in
- let uctx = ref (Evd.universe_context_set !evars) in
- let fn status (id, b, t) =
- if Lib.is_modtype () && not (Lib.sections_are_opened ()) then
- let ctx = Univ.ContextSet.to_context !uctx in
- (* Declare the universe context once *)
- let () = uctx := Univ.ContextSet.empty in
- let decl = (ParameterEntry (None,poly,(t,ctx),None), IsAssumption Logical) in
- let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in
- match class_of_constr t with
- | Some (rels, ((tc,_), args) as _cl) ->
- add_instance (Typeclasses.new_instance tc Hints.empty_hint_info false (*FIXME*)
- poly (ConstRef cst));
- status
- (* declare_subclasses (ConstRef cst) cl *)
- | None -> status
- else
- let test (x, _) = match x with
- | ExplByPos (_, Some id') -> Id.equal id id'
- | _ -> false
- in
- let impl = List.exists test impls in
- let decl = (Discharge, poly, Definitional) in
- let nstatus =
- pi3 (Command.declare_assumption false decl (t, !uctx) [] [] impl
- Vernacexpr.NoInline (Loc.ghost, id))
- in
- let () = uctx := Univ.ContextSet.empty in
- status && nstatus
- in List.fold_left fn true (List.rev ctx)
diff --git a/toplevel/classes.mli b/toplevel/classes.mli
deleted file mode 100644
index d2cb788e..00000000
--- a/toplevel/classes.mli
+++ /dev/null
@@ -1,66 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open Environ
-open Constrexpr
-open Typeclasses
-open Libnames
-
-(** Errors *)
-
-val mismatched_params : env -> constr_expr list -> Context.Rel.t -> 'a
-
-val mismatched_props : env -> constr_expr list -> Context.Rel.t -> 'a
-
-(** Instance declaration *)
-
-val existing_instance : bool -> reference -> Vernacexpr.hint_info_expr option -> unit
-(** globality, reference, optional priority and pattern information *)
-
-val declare_instance_constant :
- typeclass ->
- Vernacexpr.hint_info_expr -> (** priority *)
- bool -> (** globality *)
- Impargs.manual_explicitation list -> (** implicits *)
- ?hook:(Globnames.global_reference -> unit) ->
- Id.t -> (** name *)
- Id.t Loc.located list option ->
- bool -> (* polymorphic *)
- Evd.evar_map -> (* Universes *)
- Constr.t -> (** body *)
- Term.types -> (** type *)
- Names.Id.t
-
-val new_instance :
- ?abstract:bool -> (** Not abstract by default. *)
- ?global:bool -> (** Not global by default. *)
- ?refine:bool -> (** Allow refinement *)
- Decl_kinds.polymorphic ->
- local_binder list ->
- typeclass_constraint ->
- (bool * constr_expr) option ->
- ?generalize:bool ->
- ?tac:unit Proofview.tactic ->
- ?hook:(Globnames.global_reference -> unit) ->
- Vernacexpr.hint_info_expr ->
- Id.t
-
-(** Setting opacity *)
-
-val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit
-
-(** For generation on names based on classes only *)
-
-val id_of_class : typeclass -> Id.t
-
-(** Context command *)
-
-(** returns [false] if, for lack of section, it declares an assumption
- (unless in a module type). *)
-val context : Decl_kinds.polymorphic -> local_binder list -> bool
diff --git a/toplevel/command.ml b/toplevel/command.ml
deleted file mode 100644
index a9f2598e..00000000
--- a/toplevel/command.ml
+++ /dev/null
@@ -1,1355 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open CErrors
-open Util
-open Flags
-open Term
-open Vars
-open Termops
-open Environ
-open Redexpr
-open Declare
-open Names
-open Libnames
-open Globnames
-open Nameops
-open Constrexpr
-open Constrexpr_ops
-open Topconstr
-open Constrintern
-open Nametab
-open Impargs
-open Reductionops
-open Indtypes
-open Decl_kinds
-open Pretyping
-open Evarutil
-open Evarconv
-open Indschemes
-open Misctypes
-open Vernacexpr
-open Sigma.Notations
-open Context.Rel.Declaration
-open Entries
-
-let do_universe poly l = Declare.do_universe poly l
-let do_constraint poly l = Declare.do_constraint poly l
-
-let rec under_binders env sigma f n c =
- if Int.equal n 0 then f env sigma c else
- match kind_of_term c with
- | Lambda (x,t,c) ->
- mkLambda (x,t,under_binders (push_rel (LocalAssum (x,t)) env) sigma f (n-1) c)
- | LetIn (x,b,t,c) ->
- mkLetIn (x,b,t,under_binders (push_rel (LocalDef (x,b,t)) env) sigma f (n-1) c)
- | _ -> assert false
-
-let rec complete_conclusion a cs = function
- | CProdN (loc,bl,c) -> CProdN (loc,bl,complete_conclusion a cs c)
- | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,complete_conclusion a cs c)
- | CHole (loc, k, _, _) ->
- let (has_no_args,name,params) = a in
- if not has_no_args then
- user_err_loc (loc,"",
- strbrk"Cannot infer the non constant arguments of the conclusion of "
- ++ pr_id cs ++ str ".");
- let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in
- CAppExpl (loc,(None,Ident(loc,name),None),List.rev args)
- | c -> c
-
-(* Commands of the interface *)
-
-(* 1| Constant definitions *)
-
-let red_constant_entry n ce sigma = function
- | None -> ce
- | Some red ->
- let proof_out = ce.const_entry_body in
- let env = Global.env () in
- let (redfun, _) = reduction_of_red_expr env red in
- let redfun env sigma c =
- let sigma = Sigma.Unsafe.of_evar_map sigma in
- let Sigma (c, _, _) = redfun.e_redfun env sigma c in
- c
- in
- { ce with const_entry_body = Future.chain ~greedy:true ~pure:true proof_out
- (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) }
-
-let warn_implicits_in_term =
- CWarnings.create ~name:"implicits-in-term" ~category:"implicits"
- (fun () ->
- strbrk "Implicit arguments declaration relies on type." ++ spc () ++
- strbrk "The term declares more implicits than the type here.")
-
-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 impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in
- let nb_args = List.length ctx in
- let imps,pl,ce =
- match ctypopt with
- None ->
- let subst = evd_comb0 Evd.nf_univ_variables evdref in
- let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in
- let env_bl = push_rel_context ctx env in
- let c, imps2 = interp_constr_evars_impls ~impls env_bl evdref c in
- let nf,subst = Evarutil.e_nf_evars_and_universes evdref in
- let body = nf (it_mkLambda_or_LetIn c ctx) in
- let vars = Universes.universes_of_constr body in
- let evd = Evd.restrict_universe_context !evdref vars in
- let pl, uctx = Evd.universe_context ?names:pl evd in
- imps1@(Impargs.lift_implicits nb_args imps2), pl,
- definition_entry ~univs:uctx ~poly:p body
- | Some ctyp ->
- let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in
- let subst = evd_comb0 Evd.nf_univ_variables evdref in
- let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in
- let env_bl = push_rel_context ctx env in
- let c, imps2 = interp_casted_constr_evars_impls ~impls env_bl evdref c ty in
- let nf, subst = Evarutil.e_nf_evars_and_universes evdref in
- let body = nf (it_mkLambda_or_LetIn c ctx) in
- let typ = nf (it_mkProd_or_LetIn ty ctx) in
- let beq b1 b2 = if b1 then b2 else not b2 in
- let impl_eq (x,y,z) (x',y',z') = beq x x' && beq y y' && beq z z' in
- (* Check that all implicit arguments inferable from the term
- are inferable from the type *)
- let chk (key,va) =
- impl_eq (List.assoc_f Pervasives.(=) key impsty) va (* FIXME *)
- in
- if not (try List.for_all chk imps2 with Not_found -> false)
- then warn_implicits_in_term ();
- let vars = Univ.LSet.union (Universes.universes_of_constr body)
- (Universes.universes_of_constr typ) in
- let ctx = Evd.restrict_universe_context !evdref vars in
- let pl, uctx = Evd.universe_context ?names:pl ctx 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
-
-let check_definition (ce, evd, _, imps) =
- check_evars_are_solved (Global.env ()) evd (Evd.empty,evd);
- ce
-
-let warn_local_declaration =
- CWarnings.create ~name:"local-declaration" ~category:"scope"
- (fun (id,kind) ->
- pr_id id ++ strbrk " is declared as a local " ++ str kind)
-
-let get_locality id ~kind = function
-| Discharge ->
- (** If a Let is defined outside a section, then we consider it as a local definition *)
- warn_local_declaration (id,kind);
- true
-| Local -> true
-| Global -> false
-
-let declare_global_definition ident ce local k pl imps =
- let local = get_locality ident ~kind:"definition" local in
- let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in
- let gr = ConstRef kn in
- let () = maybe_declare_manual_implicits false gr imps in
- let () = Universes.register_universe_binders gr pl in
- let () = definition_message ident in
- gr
-
-let declare_definition_hook = ref ignore
-let set_declare_definition_hook = (:=) declare_definition_hook
-let get_declare_definition_hook () = !declare_definition_hook
-
-let warn_definition_not_visible =
- CWarnings.create ~name:"definition-not-visible" ~category:"implicits"
- (fun ident ->
- strbrk "Section definition " ++
- pr_id ident ++ strbrk " is not visible from current goals")
-
-let declare_definition ident (local, p, k) ce pl imps hook =
- let fix_exn = Future.fix_exn_of ce.const_entry_body in
- let () = !declare_definition_hook ce in
- let r = match local with
- | Discharge when Lib.sections_are_opened () ->
- let c = SectionLocalDef ce in
- let _ = declare_variable ident (Lib.cwd(), c, IsDefinition k) in
- let () = definition_message ident in
- let gr = VarRef ident in
- let () = maybe_declare_manual_implicits false gr imps in
- let () = if Pfedit.refining () then
- warn_definition_not_visible ident
- in
- gr
- | Discharge | Local | Global ->
- declare_global_definition ident ce local k pl imps in
- Lemmas.call_hook fix_exn hook local r
-
-let _ = Obligations.declare_definition_ref :=
- (fun i k c imps hook -> declare_definition i k c [] imps hook)
-
-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
- in
- if Flags.is_program_mode () then
- let env = Global.env () in
- let (c,ctx), sideff = Future.force ce.const_entry_body in
- assert(Safe_typing.empty_private_constants = sideff);
- assert(Univ.ContextSet.is_empty ctx);
- let typ = match ce.const_entry_type with
- | Some t -> t
- | None -> Retyping.get_type_of env evd c
- in
- Obligations.check_evars env evd;
- let obls, _, c, cty =
- Obligations.eterm_obligations env ident evd 0 c typ
- 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)
- else let ce = check_definition def in
- ignore(declare_definition ident k ce pl' imps
- (Lemmas.mk_hook
- (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r)))
-
-(* 2| Variable/Hypothesis/Parameter/Axiom declarations *)
-
-let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl (_,ident) =
-match local with
-| Discharge when Lib.sections_are_opened () ->
- let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in
- let _ = declare_variable ident decl in
- let () = assumption_message ident in
- let () =
- if is_verbose () && Pfedit.refining () then
- Feedback.msg_info (str"Variable" ++ spc () ++ pr_id ident ++
- strbrk " is not visible from current goals")
- in
- let r = VarRef ident in
- let () = Typeclasses.declare_instance None true r in
- let () = if is_coe then Class.try_add_new_coercion r ~local:true false in
- (r,Univ.Instance.empty,true)
-
-| Global | Local | Discharge ->
- let local = get_locality ident ~kind:"axiom" local in
- let inl = match nl with
- | NoInline -> None
- | DefaultInline -> Some (Flags.get_inline_level())
- | InlineAt i -> Some i
- in
- let ctx = Univ.ContextSet.to_context ctx in
- let decl = (ParameterEntry (None,p,(c,ctx),inl), IsAssumption kind) in
- let kn = declare_constant ident ~local decl in
- let gr = ConstRef kn in
- let () = maybe_declare_manual_implicits false gr imps in
- let () = Universes.register_universe_binders gr pl in
- let () = assumption_message ident in
- let () = Typeclasses.declare_instance None false gr in
- let () = if is_coe then Class.try_add_new_coercion gr local p in
- let inst =
- if p (* polymorphic *) then Univ.UContext.instance ctx
- else Univ.Instance.empty
- in
- (gr,inst,Lib.is_modtype_strict ())
-
-let interp_assumption evdref env impls bl c =
- let c = prod_constr_expr c bl in
- interp_type_evars_impls env evdref ~impls c
-
-let declare_assumptions idl is_coe k (c,ctx) pl imps impl_is_on nl =
- let refs, status, _ =
- List.fold_left (fun (refs,status,ctx) id ->
- let ref',u',status' =
- declare_assumption is_coe k (c,ctx) pl imps impl_is_on nl id in
- (ref',u')::refs, status' && status, Univ.ContextSet.empty)
- ([],true,ctx) idl
- in
- List.rev refs, status
-
-let do_assumptions_unbound_univs (_, poly, _ as kind) nl l =
- let open Context.Named.Declaration in
- let env = Global.env () in
- let evdref = ref (Evd.from_env env) in
- let l =
- if poly then
- (* Separate declarations so that A B : Type puts A and B in different levels. *)
- List.fold_right (fun (is_coe,(idl,c)) acc ->
- List.fold_right (fun id acc ->
- (is_coe, ([id], c)) :: acc) idl acc)
- 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 t,imps = interp_assumption evdref env ienv [] c in
- let env =
- push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in
- let ienv = List.fold_right (fun (_,id) ienv ->
- let impls = compute_internalization_data env Variable t imps in
- Id.Map.add id impls ienv) idl ienv in
- ((env,ienv),((is_coe,idl),t,imps)))
- (env,empty_internalization_env) l
- in
- let evd = solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref) in
- (* The universe constraints come from the whole telescope. *)
- let evd = Evd.nf_constraints evd in
- let ctx = Evd.universe_context_set evd in
- let l = List.map (on_pi2 (nf_evar evd)) l in
- pi2 (List.fold_left (fun (subst,status,ctx) ((is_coe,idl),t,imps) ->
- let t = replace_vars subst t in
- let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) [] imps false nl in
- let subst' = List.map2
- (fun (_,id) (c,u) -> (id,Universes.constr_of_global_univ (c,u)))
- idl refs
- in
- (subst'@subst, status' && status,
- (* The universe constraints are declared with the first declaration only. *)
- Univ.ContextSet.empty)) ([],true,ctx) 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 ty, impls = interp_type_evars_impls env evdref c in
- let nf, subst = Evarutil.e_nf_evars_and_universes evdref in
- let ty = nf ty in
- let vars = Universes.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 uctx = Univ.ContextSet.of_context uctx in
- let (_, _, st) = declare_assumption coe kind (ty, uctx) pl impls false nl id in
- st
-
-let do_assumptions kind nl l = match l with
-| [coe, ([id, Some pl], c)] ->
- let () = match kind with
- | (Discharge, _, _) when Lib.sections_are_opened () ->
- let loc = fst id in
- let msg = Pp.str "Section variables cannot be polymorphic." in
- user_err_loc (loc, "", msg)
- | _ -> ()
- in
- do_assumptions_bound_univs coe kind nl id (Some pl) c
-| _ ->
- let map (coe, (idl, c)) =
- let map (id, univs) = match univs with
- | None -> id
- | Some _ ->
- let loc = fst id in
- let msg =
- Pp.str "Assumptions with bound universes can only be defined one at a time." in
- user_err_loc (loc, "", msg)
- in
- (coe, (List.map map idl, c))
- in
- let l = List.map map l in
- do_assumptions_unbound_univs kind nl l
-
-(* 3a| Elimination schemes for mutual inductive definitions *)
-
-(* 3b| Mutual inductive definitions *)
-
-let push_types env idl tl =
- List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env)
- env idl tl
-
-type structured_one_inductive_expr = {
- ind_name : Id.t;
- ind_univs : lident list option;
- ind_arity : constr_expr;
- ind_lc : (Id.t * constr_expr) list
-}
-
-type structured_inductive_expr =
- local_binder list * structured_one_inductive_expr list
-
-let minductive_message warn = function
- | [] -> error "No inductive definition."
- | [x] -> (pr_id x ++ str " is defined" ++
- if warn then str " as a non-primitive record" else mt())
- | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++
- spc () ++ str "are defined")
-
-let check_all_names_different indl =
- let ind_names = List.map (fun ind -> ind.ind_name) indl in
- let cstr_names = List.map_append (fun ind -> List.map fst ind.ind_lc) indl in
- let l = List.duplicates Id.equal ind_names in
- let () = match l with
- | [] -> ()
- | t :: _ -> raise (InductiveError (SameNamesTypes t))
- in
- let l = List.duplicates Id.equal cstr_names in
- let () = match l with
- | [] -> ()
- | c :: _ -> raise (InductiveError (SameNamesConstructors (List.hd l)))
- in
- let l = List.intersect Id.equal ind_names cstr_names in
- match l with
- | [] -> ()
- | _ -> raise (InductiveError (SameNamesOverlap l))
-
-let mk_mltype_data evdref env assums arity indname =
- let is_ml_type = is_sort env !evdref arity in
- (is_ml_type,indname,assums)
-
-let prepare_param = function
- | LocalAssum (na,t) -> out_name na, LocalAssumEntry t
- | LocalDef (na,b,_) -> out_name na, LocalDefEntry b
-
-(** Make the arity conclusion flexible to avoid generating an upper bound universe now,
- only if the universe does not appear anywhere else.
- This is really a hack to stay compatible with the semantics of template polymorphic
- inductives which are recognized when a "Type" appears at the end of the conlusion in
- the source syntax. *)
-
-let rec check_anonymous_type ind =
- let open Glob_term in
- match ind with
- | GSort (_, GType []) -> true
- | GProd (_, _, _, _, e)
- | GLetIn (_, _, _, e)
- | GLambda (_, _, _, _, e)
- | GApp (_, e, _)
- | GCast (_, e, _) -> check_anonymous_type e
- | _ -> false
-
-let make_conclusion_flexible evdref ty poly =
- if poly && isArity ty then
- let _, concl = destArity ty in
- match concl with
- | Type u ->
- (match Univ.universe_level u with
- | Some u ->
- evdref := Evd.make_flexible_variable !evdref true u
- | None -> ())
- | _ -> ()
- else ()
-
-let is_impredicative env u =
- u = Prop Null || (is_impredicative_set env && u = Prop Pos)
-
-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 pseudo_poly = check_anonymous_type c in
- let () = if not (Reduction.is_arity env t) then
- user_err_loc (constr_loc ind.ind_arity, "", str "Not an arity")
- in
- t, pseudo_poly, impls
-
-let interp_cstrs evdref env impls mldata arity ind =
- let cnames,ctyps = List.split ind.ind_lc in
- (* Complete conclusions of constructor types if given in ML-style syntax *)
- let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in
- (* Interpret the constructor types *)
- let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls evdref env ~impls) ctyps') in
- (cnames, ctyps'', cimpls)
-
-let sign_level env evd sign =
- fst (List.fold_right
- (fun d (lev,env) ->
- match d with
- | LocalDef _ -> lev, push_rel d env
- | LocalAssum _ ->
- let s = destSort (Reduction.whd_all env
- (nf_evar evd (Retyping.get_type_of env evd (get_type d))))
- in
- let u = univ_of_sort s in
- (Univ.sup u lev, push_rel d env))
- sign (Univ.type0m_univ,env))
-
-let sup_list min = List.fold_left Univ.sup min
-
-let extract_level env evd min tys =
- let sorts = List.map (fun ty ->
- let ctx, concl = Reduction.dest_prod_assum env ty in
- sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys
- in sup_list min sorts
-
-let is_flexible_sort evd u =
- match Univ.Universe.level u with
- | Some l -> Evd.is_flexible_level evd l
- | None -> false
-
-let inductive_levels env evdref poly arities inds =
- let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in
- let levels = List.map (fun (x,(ctx,a)) ->
- if a = Prop Null then None
- else Some (univ_of_sort a)) destarities
- in
- let cstrs_levels, min_levels, sizes =
- CList.split3
- (List.map2 (fun (_,tys,_) (arity,(ctx,du)) ->
- let len = List.length tys in
- let minlev = Sorts.univ_of_sort du in
- let minlev =
- if len > 1 && not (is_impredicative env du) then
- Univ.sup minlev Univ.type0_univ
- else minlev
- in
- let minlev =
- (** Indices contribute. *)
- if Indtypes.is_indices_matter () && List.length ctx > 0 then (
- let ilev = sign_level env !evdref ctx in
- Univ.sup ilev minlev)
- else minlev
- in
- let clev = extract_level env !evdref minlev tys in
- (clev, minlev, len)) inds destarities)
- in
- (* Take the transitive closure of the system of constructors *)
- (* level constraints and remove the recursive dependencies *)
- let levels' = Universes.solve_constraints_system (Array.of_list levels)
- (Array.of_list cstrs_levels) (Array.of_list min_levels)
- in
- let evd, arities =
- CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len ->
- if is_impredicative env du then
- (** Any product is allowed here. *)
- evd, arity :: arities
- else (** If in a predicative sort, or asked to infer the type,
- we take the max of:
- - indices (if in indices-matter mode)
- - constructors
- - Type(1) if there is more than 1 constructor
- *)
- (** Constructors contribute. *)
- let evd =
- if Sorts.is_set du then
- if not (Evd.check_leq evd cu Univ.type0_univ) then
- raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType)
- else evd
- else evd
- (* Evd.set_leq_sort env evd (Type cu) du *)
- in
- let evd =
- if len >= 2 && Univ.is_type0m_univ cu then
- (** "Polymorphic" type constraint and more than one constructor,
- should not land in Prop. Add constraint only if it would
- land in Prop directly (no informative arguments as well). *)
- Evd.set_leq_sort env evd (Prop Pos) du
- else evd
- in
- let duu = Sorts.univ_of_sort du in
- let evd =
- if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then
- if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then
- Evd.set_eq_sort env evd (Prop Null) du
- else evd
- else Evd.set_eq_sort env evd (Type cu) du
- in
- (evd, arity :: arities))
- (!evdref,[]) (Array.to_list levels') destarities sizes
- in evdref := evd; List.rev arities
-
-let check_named (loc, na) = match na with
-| Name _ -> ()
-| Anonymous ->
- let msg = str "Parameters must be named." in
- user_err_loc (loc, "", msg)
-
-
-let check_param = function
-| LocalRawDef (na, _) -> check_named na
-| LocalRawAssum (nas, Default _, _) -> List.iter check_named nas
-| LocalRawAssum (nas, Generalized _, _) -> ()
-| LocalPattern _ -> assert false
-
-let interp_mutual_inductive (paramsl,indl) notations 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 _, ((env_params, ctx_params), userimpls) =
- interp_context_evars env0 evdref paramsl
- in
- let indnames = List.map (fun ind -> ind.ind_name) indl in
-
- (* Names of parameters as arguments of the inductive type (defs removed) *)
- let assums = List.filter is_local_assum ctx_params in
- let params = List.map (fun decl -> out_name (get_name decl)) assums in
-
- (* Interpret the arities *)
- let arities = List.map (interp_ind_arity env_params evdref) indl in
-
- let fullarities = List.map (fun (c, _, _) -> it_mkProd_or_LetIn c ctx_params) arities in
- let env_ar = push_types env0 indnames fullarities in
- let env_ar_params = push_rel_context ctx_params env_ar in
-
- (* Compute interpretation metadatas *)
- let indimpls = List.map (fun (_, _, impls) -> userimpls @
- 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 (Inductive params) 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 impls) notations;
- (* Interpret the constructor types *)
- List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl)
- () in
-
- (* Try further to solve evars, and instantiate them *)
- let sigma = solve_remaining_evars all_and_fail_flags env_params !evdref (Evd.empty,!evdref) in
- evdref := sigma;
- (* Compute renewed arities *)
- let nf,_ = e_nf_evars_and_universes evdref in
- let arities = List.map nf arities in
- let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in
- let _ = List.iter2 (fun ty poly -> make_conclusion_flexible evdref ty poly) arities aritypoly in
- let arities = inductive_levels env_ar_params evdref poly arities constructors in
- let nf',_ = e_nf_evars_and_universes evdref in
- let nf x = nf' (nf x) in
- let arities = List.map nf' arities in
- 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
- List.iter (check_evars env_params Evd.empty evd) arities;
- Context.Rel.iter (check_evars env0 Evd.empty evd) ctx_params;
- List.iter (fun (_,ctyps,_) ->
- List.iter (check_evars env_ar_params Evd.empty evd) ctyps)
- constructors;
-
- (* Build the inductive entries *)
- let entries = List.map4 (fun ind arity template (cnames,ctypes,cimpls) -> {
- mind_entry_typename = ind.ind_name;
- mind_entry_arity = arity;
- mind_entry_template = template;
- mind_entry_consnames = cnames;
- mind_entry_lc = ctypes
- }) indl arities aritypoly constructors in
- let impls =
- let len = Context.Rel.nhyps ctx_params in
- List.map2 (fun indimpls (_,_,cimpls) ->
- indimpls, List.map (fun impls ->
- userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors
- in
- (* Build the mutual inductive entry *)
- { mind_entry_params = List.map prepare_param ctx_params;
- mind_entry_record = None;
- mind_entry_finite = finite;
- mind_entry_inds = entries;
- mind_entry_polymorphic = poly;
- mind_entry_private = if prv then Some false else None;
- mind_entry_universes = uctx;
- },
- pl, impls
-
-(* Very syntactical equality *)
-let eq_local_binders bl1 bl2 =
- List.equal local_binder_eq bl1 bl2
-
-let extract_coercions indl =
- let mkqid (_,((_,id),_)) = qualid_of_ident id in
- let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in
- List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl))
-
-let extract_params indl =
- let paramsl = List.map (fun (_,params,_,_) -> params) indl in
- match paramsl with
- | [] -> anomaly (Pp.str "empty list of inductive types")
- | params::paramsl ->
- if not (List.for_all (eq_local_binders params) paramsl) then error
- "Parameters should be syntactically the same for each inductive type.";
- params
-
-let extract_inductive indl =
- List.map (fun (((_,indname),pl),_,ar,lc) -> {
- ind_name = indname; ind_univs = pl;
- ind_arity = Option.cata (fun x -> x) (CSort (Loc.ghost,GType [])) ar;
- ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc
- }) indl
-
-let extract_mutual_inductive_declaration_components indl =
- let indl,ntnl = List.split indl in
- let params = extract_params indl in
- let coes = extract_coercions indl in
- let indl = extract_inductive indl in
- (params,indl), coes, List.flatten ntnl
-
-let is_recursive mie =
- let rec is_recursive_constructor lift typ =
- match Term.kind_of_term typ with
- | Prod (_,arg,rest) ->
- Termops.dependent (mkRel lift) arg ||
- is_recursive_constructor (lift+1) rest
- | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest
- | _ -> false
- in
- match mie.mind_entry_inds with
- | [ind] ->
- let nparams = List.length mie.mind_entry_params in
- List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc
- | _ -> false
-
-let declare_mutual_inductive_with_eliminations mie pl impls =
- (* spiwack: raises an error if the structure is supposed to be non-recursive,
- but isn't *)
- begin match mie.mind_entry_finite with
- | BiFinite when is_recursive mie ->
- if Option.has_some mie.mind_entry_record then
- error "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command."
- else
- error ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.")
- | _ -> ()
- end;
- let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in
- let (_, kn), prim = declare_mind mie in
- let mind = Global.mind_of_delta_kn kn in
- List.iteri (fun i (indimpls, constrimpls) ->
- let ind = (mind,i) in
- let gr = IndRef ind in
- maybe_declare_manual_implicits false gr indimpls;
- Universes.register_universe_binders gr pl;
- List.iteri
- (fun j impls ->
- maybe_declare_manual_implicits false
- (ConstructRef (ind, succ j)) 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);
- if mie.mind_entry_private == None
- then declare_default_schemes mind;
- mind
-
-type one_inductive_impls =
- Impargs.manual_explicitation list (* for inds *)*
- Impargs.manual_explicitation list list (* for constrs *)
-
-let do_mutual_inductive indl poly prv finite =
- let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in
- (* Interpret the types *)
- let mie,pl,impls = interp_mutual_inductive indl ntns poly prv finite in
- (* 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;
- (* Declare the coercions *)
- List.iter (fun qid -> Class.try_add_new_coercion (locate qid) false poly) coes;
- (* If positivity is assumed declares itself as unsafe. *)
- if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else ()
-
-(* 3c| Fixpoints and co-fixpoints *)
-
-(* An (unoptimized) function that maps preorders to partial orders...
-
- Input: a list of associations (x,[y1;...;yn]), all yi distincts
- and different of x, meaning x<=y1, ..., x<=yn
-
- Output: a list of associations (x,Inr [y1;...;yn]), collecting all
- distincts yi greater than x, _or_, (x, Inl y) meaning that
- x is in the same class as y (in which case, x occurs
- nowhere else in the association map)
-
- partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list
-*)
-
-let rec partial_order cmp = function
- | [] -> []
- | (x,xge)::rest ->
- let rec browse res xge' = function
- | [] ->
- let res = List.map (function
- | (z, Inr zge) when List.mem_f cmp x zge ->
- (z, Inr (List.union cmp zge xge'))
- | r -> r) res in
- (x,Inr xge')::res
- | y::xge ->
- let rec link y =
- try match List.assoc_f cmp y res with
- | Inl z -> link z
- | Inr yge ->
- if List.mem_f cmp x yge then
- let res = List.remove_assoc_f cmp y res in
- let res = List.map (function
- | (z, Inl t) ->
- if cmp t y then (z, Inl x) else (z, Inl t)
- | (z, Inr zge) ->
- if List.mem_f cmp y zge then
- (z, Inr (List.add_set cmp x (List.remove cmp y zge)))
- else
- (z, Inr zge)) res in
- browse ((y,Inl x)::res) xge' (List.union cmp xge (List.remove cmp x yge))
- else
- browse res (List.add_set cmp y (List.union cmp xge' yge)) xge
- with Not_found -> browse res (List.add_set cmp y xge') xge
- in link y
- in browse (partial_order cmp rest) [] xge
-
-let non_full_mutual_message x xge y yge isfix rest =
- let reason =
- if Id.List.mem x yge then
- pr_id y ++ str " depends on " ++ pr_id x ++ strbrk " but not conversely"
- else if Id.List.mem y xge then
- pr_id x ++ str " depends on " ++ pr_id y ++ strbrk " but not conversely"
- else
- pr_id y ++ str " and " ++ pr_id x ++ strbrk " are not mutually dependent" in
- let e = if List.is_empty rest then reason else strbrk "e.g., " ++ reason in
- let k = if isfix then "fixpoint" else "cofixpoint" in
- let w =
- if isfix
- then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl()
- else mt () in
- strbrk "Not a fully mutually defined " ++ str k ++ fnl () ++
- str "(" ++ e ++ str ")." ++ fnl () ++ w
-
-let warn_non_full_mutual =
- CWarnings.create ~name:"non-full-mutual" ~category:"fixpoints"
- (fun (x,xge,y,yge,isfix,rest) ->
- non_full_mutual_message x xge y yge isfix rest)
-
-let check_mutuality env isfix fixl =
- let names = List.map fst fixl in
- let preorder =
- List.map (fun (id,def) ->
- (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env id' def) names))
- fixl in
- let po = partial_order Id.equal preorder in
- match List.filter (function (_,Inr _) -> true | _ -> false) po with
- | (x,Inr xge)::(y,Inr yge)::rest ->
- warn_non_full_mutual (x,xge,y,yge,isfix,rest)
- | _ -> ()
-
-type structured_fixpoint_expr = {
- fix_name : Id.t;
- fix_univs : lident list option;
- fix_annot : Id.t Loc.located option;
- fix_binders : local_binder list;
- fix_body : constr_expr option;
- fix_type : constr_expr
-}
-
-let interp_fix_context env evdref isfix fix =
- let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in
- let impl_env, ((env', ctx), imps) = interp_context_evars env evdref before in
- let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env ~shift:(List.length before) env' evdref after in
- let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in
- ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot)
-
-let interp_fix_ccl evdref impls (env,_) fix =
- interp_type_evars_impls ~impls env evdref fix.fix_type
-
-let interp_fix_body env_rec evdref impls (_,ctx) fix ccl =
- Option.map (fun body ->
- let env = push_rel_context ctx env_rec in
- let body = interp_casted_constr_evars env evdref ~impls body ccl in
- it_mkLambda_or_LetIn body ctx) fix.fix_body
-
-let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
-
-let declare_fix ?(opaque = false) (_,poly,_ as kind) pl ctx f ((def,_),eff) t imps =
- let ce = definition_entry ~opaque ~types:t ~poly ~univs:ctx ~eff def in
- declare_definition f kind ce pl imps (Lemmas.mk_hook (fun _ r -> r))
-
-let _ = Obligations.declare_fix_ref :=
- (fun ?opaque k ctx f d t imps -> declare_fix ?opaque k [] ctx f d t imps)
-
-let prepare_recursive_declaration fixnames fixtypes fixdefs =
- let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
- let names = List.map (fun id -> Name id) fixnames in
- (Array.of_list names, Array.of_list fixtypes, Array.of_list defs)
-
-(* Jump over let-bindings. *)
-
-let compute_possible_guardness_evidences (ids,_,na) =
- match na with
- | Some i -> [i]
- | None ->
- (* If recursive argument was not given by user, we try all args.
- An earlier approach was to look only for inductive arguments,
- but doing it properly involves delta-reduction, and it finally
- doesn't seem to worth the effort (except for huge mutual
- fixpoints ?) *)
- List.interval 0 (List.length ids - 1)
-
-type recursive_preentry =
- Id.t list * constr option list * types list
-
-(* Wellfounded definition *)
-
-open Coqlib
-
-let contrib_name = "Program"
-let subtac_dir = [contrib_name]
-let fixsub_module = subtac_dir @ ["Wf"]
-let tactics_module = subtac_dir @ ["Tactics"]
-
-let init_reference dir s () = Coqlib.gen_reference "Command" dir s
-let init_constant dir s () = Coqlib.gen_constant "Command" dir s
-let make_ref l s = init_reference l s
-let fix_proto = init_constant tactics_module "fix_proto"
-let fix_sub_ref = make_ref fixsub_module "Fix_sub"
-let measure_on_R_ref = make_ref fixsub_module "MR"
-let well_founded = init_constant ["Init"; "Wf"] "well_founded"
-let mkSubset name typ prop =
- mkApp (Universes.constr_of_global (delayed_force build_sigma).typ,
- [| typ; mkLambda (name, typ, prop) |])
-let sigT = Lazy.from_fun build_sigma_type
-
-let make_qref s = Qualid (Loc.ghost, qualid_of_string s)
-let lt_ref = make_qref "Init.Peano.lt"
-
-let rec telescope = function
- | [] -> assert false
- | [LocalAssum (n, t)] -> t, [LocalDef (n, mkRel 1, t)], mkRel 1
- | LocalAssum (n, t) :: tl ->
- let ty, tys, (k, constr) =
- List.fold_left
- (fun (ty, tys, (k, constr)) decl ->
- let t = get_type decl in
- let pred = mkLambda (get_name decl, t, ty) in
- let ty = Universes.constr_of_global (Lazy.force sigT).typ in
- let intro = Universes.constr_of_global (Lazy.force sigT).intro in
- let sigty = mkApp (ty, [|t; pred|]) in
- let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in
- (sigty, pred :: tys, (succ k, intro)))
- (t, [], (2, mkRel 1)) tl
- in
- let (last, subst) = List.fold_right2
- (fun pred decl (prev, subst) ->
- let t = get_type decl in
- let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in
- let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in
- let proj1 = applistc p1 [t; pred; prev] in
- let proj2 = applistc p2 [t; pred; prev] in
- (lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst))
- (List.rev tys) tl (mkRel 1, [])
- in ty, (LocalDef (n, last, t) :: subst), constr
-
- | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope tl in
- ty, (LocalDef (n, b, t) :: subst), lift 1 term
-
-let nf_evar_context sigma ctx =
- List.map (map_constr (Evarutil.nf_evar sigma)) ctx
-
-let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
- 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 _, ((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
- let top_arity = interp_type_evars top_env evdref arityc in
- let full_arity = it_mkProd_or_LetIn top_arity binders_rel in
- let argtyp, letbinders, make = telescope binders_rel in
- let argname = Id.of_string "recarg" in
- let arg = LocalAssum (Name argname, argtyp) in
- let binders = letbinders @ [arg] in
- let binders_env = push_rel_context binders_rel env in
- let rel, _ = interp_constr_evars_impls env evdref r in
- let relty = Typing.unsafe_type_of env !evdref rel in
- let relargty =
- let error () =
- user_err_loc (constr_loc r,
- "Command.build_wellfounded",
- Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.")
- in
- try
- let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in
- match ctx, kind_of_term ar with
- | [LocalAssum (_,t); LocalAssum (_,u)], Sort (Prop Null)
- when Reductionops.is_conv env !evdref t u -> t
- | _, _ -> error ()
- with e when CErrors.noncritical e -> error ()
- in
- let measure = interp_casted_constr_evars binders_env evdref measure relargty in
- let wf_rel, wf_rel_fun, measure_fn =
- let measure_body, measure =
- it_mkLambda_or_LetIn measure letbinders,
- it_mkLambda_or_LetIn measure binders
- in
- let comb = Universes.constr_of_global (delayed_force measure_on_R_ref) in
- let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in
- let wf_rel_fun x y =
- mkApp (rel, [| subst1 x measure_body;
- subst1 y measure_body |])
- in wf_rel, wf_rel_fun, measure
- in
- let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in
- let argid' = Id.of_string (Id.to_string argname ^ "'") in
- let wfarg len = LocalAssum (Name argid',
- mkSubset (Name argid') argtyp
- (wf_rel_fun (mkRel 1) (mkRel (len + 1))))
- in
- let intern_bl = wfarg 1 :: [arg] in
- let _intern_env = push_rel_context intern_bl env in
- let proj = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.proj1 in
- let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in
- let projection = (* in wfarg :: arg :: before *)
- mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |])
- in
- let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in
- let intern_arity = substl [projection] top_arity_let in
- (* substitute the projection of wfarg for something,
- now intern_arity is in wfarg :: arg *)
- let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
- let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in
- let curry_fun =
- let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in
- let intro = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.intro in
- let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
- let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in
- let rcurry = mkApp (rel, [| measure; lift len measure |]) in
- let lam = LocalAssum (Name (Id.of_string "recproof"), rcurry) in
- let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in
- let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in
- LocalDef (Name recname, body, ty)
- in
- let fun_bl = intern_fun_binder :: [arg] in
- let lift_lets = Termops.lift_rel_context 1 letbinders in
- let intern_body =
- let ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in
- let (r, l, impls, scopes) =
- Constrintern.compute_internalization_data env
- Constrintern.Recursive full_arity impls
- in
- let newimpls = Id.Map.singleton recname
- (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))],
- scopes @ [None]) in
- interp_casted_constr_evars (push_rel_context ctx env) evdref
- ~impls:newimpls body (lift 1 top_arity)
- in
- let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in
- let prop = mkLambda (Name argname, argtyp, top_arity_let) in
- let def =
- mkApp (Universes.constr_of_global (delayed_force fix_sub_ref),
- [| argtyp ; wf_rel ;
- Evarutil.e_new_evar env evdref
- ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof;
- prop |])
- in
- let def = Typing.e_solve_evars env evdref def in
- let _ = evdref := Evarutil.nf_evar_map !evdref in
- let def = mkApp (def, [|intern_body_lam|]) in
- 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 =
- 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 (Universes.constr_of_global gr, [|make|])) binders_rel in
- let ty = it_mkProd_or_LetIn top_arity binders_rel in
- let pl, univs = Evd.universe_context ?names:pl !evdref in
- (*FIXME poly? *)
- let ce = definition_entry ~poly ~types:ty ~univs (Evarutil.nf_evar !evdref body) in
- (** FIXME: include locality *)
- let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
- let gr = ConstRef c in
- if Impargs.is_implicit_args () || not (List.is_empty impls) then
- Impargs.declare_manual_implicits false gr [impls]
- in
- let typ = it_mkProd_or_LetIn top_arity binders in
- hook, name, typ
- else
- let typ = it_mkProd_or_LetIn top_arity binders_rel in
- let hook l gr _ =
- if Impargs.is_implicit_args () || not (List.is_empty impls) then
- Impargs.declare_manual_implicits false gr [impls]
- in hook, recname, typ
- in
- let hook = Lemmas.mk_hook hook in
- let fullcoqc = Evarutil.nf_evar !evdref def in
- let fullctyp = Evarutil.nf_evar !evdref typ in
- Obligations.check_evars env !evdref;
- let evars, _, evars_def, evars_typ =
- 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
- evars_typ ctx evars ~hook)
-
-let interp_recursive isfix fixl notations =
- let open Context.Named.Declaration in
- let env = Global.env() in
- let fixnames = List.map (fun fix -> fix.fix_name) fixl in
-
- (* Interp arities allowing for unresolved types *)
- let all_universes =
- List.fold_right (fun sfe acc ->
- match sfe.fix_univs , acc with
- | 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
- error "(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 fixctxs, fiximppairs, fixannots =
- List.split3 (List.map (interp_fix_context env evdref isfix) fixl) in
- let fixctximpenvs, fixctximps = List.split fiximppairs in
- let fixccls,fixcclimps = List.split (List.map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in
- let fixtypes = List.map2 build_fix_type fixctxs fixccls in
- let fixtypes = List.map (nf_evar !evdref) fixtypes in
- let fiximps = List.map3
- (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (List.length ctx) cclimps))
- fixctximps fixcclimps fixctxs in
- let rec_sign =
- List.fold_left2
- (fun env' id t ->
- if Flags.is_program_mode () then
- let sort = Evarutil.evd_comb1 (Typing.type_of ~refresh:true env) evdref t in
- let fixprot =
- try
- let app = mkApp (delayed_force fix_proto, [|sort; t|]) in
- Typing.e_solve_evars env evdref app
- with e when CErrors.noncritical e -> t
- in
- LocalAssum (id,fixprot) :: env'
- else LocalAssum (id,t) :: env')
- [] fixnames fixtypes
- in
- let env_rec = push_named_context rec_sign env in
-
- (* Get interpretation metadatas *)
- let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in
-
- (* 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.map4
- (fun fixctximpenv -> interp_fix_body env_rec evdref (Id.Map.fold Id.Map.add fixctximpenv impls))
- fixctximpenvs fixctxs fixl fixccls)
- () in
-
- (* Instantiate evars and check all are resolved *)
- let evd = solve_unif_constraints_with_heuristics env_rec !evdref in
- let evd, nf = nf_evars_and_universes evd in
- let fixdefs = List.map (Option.map nf) fixdefs in
- let fixtypes = List.map nf fixtypes in
- let fixctxnames = List.map (fun (_,ctx) -> List.map get_name ctx) fixctxs in
-
- (* Build the fix declaration block *)
- (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots
-
-let check_recursive isfix env evd (fixnames,fixdefs,_) =
- check_evars_are_solved env evd (Evd.empty,evd);
- if List.for_all Option.has_some fixdefs then begin
- let fixdefs = List.map Option.get fixdefs in
- check_mutuality env isfix (List.combine fixnames fixdefs)
- end
-
-let interp_fixpoint l ntns =
- let (env,_,pl,evd),fix,info = interp_recursive true l ntns in
- check_recursive true env evd fix;
- (fix,pl,Evd.evar_universe_context evd,info)
-
-let interp_cofixpoint l ntns =
- let (env,_,pl,evd),fix,info = interp_recursive false l ntns in
- check_recursive false env evd fix;
- (fix,pl,Evd.evar_universe_context evd,info)
-
-let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns =
- if List.exists Option.is_empty fixdefs then
- (* Some bodies to define by proof *)
- let thms =
- List.map3 (fun id t (len,imps,_) -> ((id,pl),(t,(len,imps))))
- fixnames fixtypes fiximps in
- let init_tac =
- Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC)
- fixdefs) in
- let init_tac =
- Option.map (List.map Proofview.V82.tactic) init_tac
- 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 _ _ -> ()))
- else begin
- (* We shortcut the proof process *)
- let fixdefs = List.map Option.get fixdefs in
- let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
- let env = Global.env() in
- let indexes = search_guard Loc.ghost env indexes fixdecls in
- let fiximps = List.map (fun (n,r,p) -> r) fiximps in
- let vars = Universes.universes_of_constr (mkFix ((indexes,0),fixdecls)) in
- let fixdecls =
- 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 fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in
- let pl, ctx = Evd.universe_context ?names:pl evd in
- ignore (List.map4 (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
-
-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 (len,imps,_) -> ((id,pl),(t,(len,imps))))
- fixnames fixtypes fiximps in
- let init_tac =
- Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC)
- fixdefs) in
- let init_tac =
- Option.map (List.map Proofview.V82.tactic) init_tac
- 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 _ _ -> ()))
- else begin
- (* We shortcut the proof process *)
- let fixdefs = List.map Option.get fixdefs in
- let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
- let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in
- let vars = Universes.universes_of_constr (List.hd fixdecls) in
- let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in
- 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 (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
-
-let extract_decreasing_argument limit = function
- | (na,CStructRec) -> na
- | (na,_) when not limit -> na
- | _ -> error
- "Only structural decreasing is supported for a non-Program Fixpoint"
-
-let extract_fixpoint_components limit l =
- let fixl, ntnl = List.split l in
- let fixl = List.map (fun (((_,id),pl),ann,bl,typ,def) ->
- let ann = extract_decreasing_argument limit ann in
- {fix_name = id; fix_annot = ann; fix_univs = pl;
- fix_binders = bl; fix_body = def; fix_type = typ}) fixl in
- fixl, List.flatten ntnl
-
-let extract_cofixpoint_components l =
- let fixl, ntnl = List.split l in
- List.map (fun (((_,id),pl),bl,typ,def) ->
- {fix_name = id; fix_annot = None; fix_univs = pl;
- fix_binders = bl; fix_body = def; fix_type = typ}) fixl,
- List.flatten ntnl
-
-let out_def = function
- | Some def -> def
- | None -> error "Program Fixpoint needs defined bodies."
-
-let collect_evars_of_term evd c ty =
- let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in
- Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev))
- evars (Evd.from_ctx (Evd.evar_universe_context evd))
-
-let do_program_recursive local p fixkind fixl ntns =
- let isfix = fixkind != Obligations.IsCoFixpoint in
- let (env, rec_sign, pl, evd), fix, info =
- interp_recursive isfix fixl ntns
- in
- (* Program-specific code *)
- (* Get the interesting evars, those that were not instanciated *)
- let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in
- (* Solve remaining evars *)
- let evd = nf_evar_map_undefined evd in
- let collect_evars id def typ imps =
- (* Generalize by the recursive prototypes *)
- let def =
- nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign)
- and typ =
- nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign)
- in
- let evm = collect_evars_of_term evd def typ in
- let evars, _, def, typ =
- Obligations.eterm_obligations env id evm
- (List.length rec_sign) def typ
- in (id, def, typ, imps, evars)
- in
- let (fixnames,fixdefs,fixtypes) = fix in
- let fiximps = List.map pi2 info in
- let fixdefs = List.map out_def fixdefs in
- let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in
- let () = if isfix then begin
- let possible_indexes = List.map compute_possible_guardness_evidences info in
- let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames),
- Array.of_list fixtypes,
- Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs)
- in
- let indexes =
- Pretyping.search_guard
- Loc.ghost (Global.env ()) possible_indexes fixdecls in
- List.iteri (fun i _ ->
- Inductive.check_fix env
- ((indexes,i),fixdecls))
- fixl
- end in
- let ctx = Evd.evar_universe_context evd in
- let kind = match fixkind with
- | Obligations.IsFixpoint _ -> (local, p, Fixpoint)
- | Obligations.IsCoFixpoint -> (local, p, CoFixpoint)
- in
- Obligations.add_mutual_definitions defs ~kind ?pl ctx ntns fixkind
-
-let do_program_fixpoint local poly l =
- let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
- match g, l with
- | [(n, CWfRec r)], [((((_,id),pl),_,bl,typ,def),ntn)] ->
- let recarg =
- match n with
- | Some n -> mkIdentC (snd n)
- | None ->
- errorlabstrm "do_program_fixpoint"
- (str "Recursive argument required for well-founded fixpoints")
- in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn
-
- | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] ->
- build_wellfounded (id, pl, n, bl, typ, out_def def) poly
- (Option.default (CRef (lt_ref,None)) r) m ntn
-
- | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g ->
- let fixl,ntns = extract_fixpoint_components true l in
- let fixkind = Obligations.IsFixpoint g in
- do_program_recursive local poly fixkind fixl ntns
-
- | _, _ ->
- errorlabstrm "do_program_fixpoint"
- (str "Well-founded fixpoints not allowed in mutually recursive blocks")
-
-let check_safe () =
- let open Declarations in
- let flags = Environ.typing_flags (Global.env ()) in
- flags.check_universes && flags.check_guarded
-
-let do_fixpoint local poly l =
- if Flags.is_program_mode () then do_program_fixpoint local poly l
- else
- let fixl, ntns = extract_fixpoint_components true l in
- let (_, _, _, info as fix) = interp_fixpoint fixl ntns in
- let possible_indexes =
- List.map compute_possible_guardness_evidences info in
- declare_fixpoint local poly fix possible_indexes ntns;
- if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else ()
-
-let do_cofixpoint local poly l =
- let fixl,ntns = extract_cofixpoint_components l in
- if Flags.is_program_mode () then
- do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns
- else
- let cofix = interp_cofixpoint fixl ntns in
- declare_cofixpoint local poly cofix ntns;
- if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else ()
diff --git a/toplevel/command.mli b/toplevel/command.mli
deleted file mode 100644
index 616afb91..00000000
--- a/toplevel/command.mli
+++ /dev/null
@@ -1,176 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open Term
-open Entries
-open Libnames
-open Globnames
-open Vernacexpr
-open Constrexpr
-open Decl_kinds
-open Redexpr
-open Pfedit
-
-(** This file is about the interpretation of raw commands into typed
- ones and top-level declaration of the main Gallina objects *)
-
-val do_universe : polymorphic -> Id.t Loc.located list -> unit
-val do_constraint : polymorphic ->
- (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit
-
-(** {6 Hooks for Pcoq} *)
-
-val set_declare_definition_hook : (Safe_typing.private_constants definition_entry -> unit) -> unit
-val get_declare_definition_hook : unit -> (Safe_typing.private_constants definition_entry -> unit)
-
-(** {6 Definitions/Let} *)
-
-val interp_definition :
- lident list option -> local_binder 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
-
-val declare_definition : Id.t -> definition_kind ->
- Safe_typing.private_constants definition_entry -> Universes.universe_binders -> Impargs.manual_implicits ->
- Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference
-
-val do_definition : Id.t -> definition_kind -> lident list option ->
- local_binder list -> red_expr option -> constr_expr ->
- constr_expr option -> unit Lemmas.declaration_hook -> unit
-
-(** {6 Parameters/Assumptions} *)
-
-(* val interp_assumption : env -> evar_map ref -> *)
-(* local_binder list -> constr_expr -> *)
-(* types Univ.in_universe_context_set * Impargs.manual_implicits *)
-
-(** returns [false] if the assumption is neither local to a section,
- nor in a module type and meant to be instantiated. *)
-val declare_assumption : coercion_flag -> assumption_kind ->
- types Univ.in_universe_context_set ->
- Universes.universe_binders -> Impargs.manual_implicits ->
- bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located ->
- global_reference * Univ.Instance.t * bool
-
-val do_assumptions : locality * polymorphic * assumption_object_kind ->
- Vernacexpr.inline -> (plident list * constr_expr) with_coercion list -> bool
-
-(* val declare_assumptions : variable Loc.located list -> *)
-(* coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> *)
-(* Impargs.manual_implicits -> bool -> Vernacexpr.inline -> bool *)
-
-(** {6 Inductive and coinductive types} *)
-
-(** Extracting the semantical components out of the raw syntax of mutual
- inductive declarations *)
-
-type structured_one_inductive_expr = {
- ind_name : Id.t;
- ind_univs : lident list option;
- ind_arity : constr_expr;
- ind_lc : (Id.t * constr_expr) list
-}
-
-type structured_inductive_expr =
- local_binder list * structured_one_inductive_expr list
-
-val extract_mutual_inductive_declaration_components :
- (one_inductive_expr * decl_notation list) list ->
- structured_inductive_expr * (*coercions:*) qualid list * decl_notation list
-
-(** Typing mutual inductive definitions *)
-
-type one_inductive_impls =
- Impargs.manual_implicits (** for inds *)*
- Impargs.manual_implicits list (** for constrs *)
-
-val interp_mutual_inductive :
- structured_inductive_expr -> decl_notation list -> polymorphic ->
- private_flag -> Decl_kinds.recursivity_kind ->
- mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list
-
-(** Registering a mutual inductive definition together with its
- associated schemes *)
-
-val declare_mutual_inductive_with_eliminations :
- mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list ->
- mutual_inductive
-
-(** Entry points for the vernacular commands Inductive and CoInductive *)
-
-val do_mutual_inductive :
- (one_inductive_expr * decl_notation list) list -> polymorphic ->
- private_flag -> Decl_kinds.recursivity_kind -> unit
-
-(** {6 Fixpoints and cofixpoints} *)
-
-type structured_fixpoint_expr = {
- fix_name : Id.t;
- fix_univs : lident list option;
- fix_annot : Id.t Loc.located option;
- fix_binders : local_binder list;
- fix_body : constr_expr option;
- fix_type : constr_expr
-}
-
-(** Extracting the semantical components out of the raw syntax of
- (co)fixpoints declarations *)
-
-val extract_fixpoint_components : bool ->
- (fixpoint_expr * decl_notation list) list ->
- structured_fixpoint_expr list * decl_notation list
-
-val extract_cofixpoint_components :
- (cofixpoint_expr * decl_notation list) list ->
- structured_fixpoint_expr list * decl_notation list
-
-(** Typing global fixpoints and cofixpoint_expr *)
-
-type recursive_preentry =
- Id.t list * constr option list * types list
-
-val interp_fixpoint :
- structured_fixpoint_expr list -> decl_notation list ->
- recursive_preentry * lident list option * Evd.evar_universe_context *
- (Name.t list * 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 *
- (Name.t list * 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 *
- (Name.t list * Impargs.manual_implicits * int option) list ->
- lemma_possible_guards -> decl_notation list -> unit
-
-val declare_cofixpoint : locality -> polymorphic ->
- recursive_preentry * lident list option * Evd.evar_universe_context *
- (Name.t list * Impargs.manual_implicits * int option) list ->
- decl_notation list -> unit
-
-(** Entry points for the vernacular commands Fixpoint and CoFixpoint *)
-
-val do_fixpoint :
- (* When [false], assume guarded. *)
- locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit
-
-val do_cofixpoint :
- (* When [false], assume guarded. *)
- locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit
-
-(** Utils *)
-
-val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit
-
-val declare_fix : ?opaque:bool -> definition_kind -> Universes.universe_binders -> Univ.universe_context -> Id.t ->
- Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference
diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml
new file mode 100644
index 00000000..eacd1dcf
--- /dev/null
+++ b/toplevel/coqargs.ml
@@ -0,0 +1,584 @@
+(************************************************************************)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
+(************************************************************************)
+
+let warning s = Flags.(with_option warn Feedback.msg_warning (Pp.strbrk s))
+
+let fatal_error ?extra exn =
+ Topfmt.print_err_exn ?extra exn;
+ let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in
+ exit exit_code
+
+let error_missing_arg s =
+ prerr_endline ("Error: extra argument expected after option "^s);
+ prerr_endline "See -help for the syntax of supported options";
+ exit 1
+
+(******************************************************************************)
+(* Imperative effects! This must be fixed at some point. *)
+(******************************************************************************)
+let set_worker_id opt s =
+ assert (s <> "master");
+ Flags.async_proofs_worker_id := s
+
+let set_type_in_type () =
+ let typing_flags = Environ.typing_flags (Global.env ()) in
+ Global.set_typing_flags { typing_flags with Declarations.check_universes = false }
+
+(******************************************************************************)
+
+type compilation_mode = BuildVo | BuildVio | Vio2Vo
+type color = [`ON | `AUTO | `OFF]
+
+type coq_cmdopts = {
+
+ load_init : bool;
+ load_rcfile : bool;
+ rcfile : string option;
+
+ ml_includes : string list;
+ vo_includes : (string * Names.DirPath.t * bool) list;
+ vo_requires : (string * string option * bool option) list;
+ (* None = No Import; Some false = Import; Some true = Export *)
+
+ (* XXX: Fusion? *)
+ batch_mode : bool;
+ compilation_mode : compilation_mode;
+
+ toplevel_name : Names.DirPath.t;
+ toploop : string option;
+
+ compile_list: (string * bool) list; (* bool is verbosity *)
+ compilation_output_name : string option;
+
+ load_vernacular_list : (string * bool) list;
+
+ vio_checking: bool;
+ vio_tasks : (int list * string) list;
+ vio_files : string list;
+ vio_files_j : int;
+
+ color : color;
+
+ impredicative_set : Declarations.set_predicativity;
+ stm_flags : Stm.AsyncOpts.stm_opt;
+ debug : bool;
+ time : bool;
+
+ filter_opts : bool;
+
+ glob_opt : bool;
+
+ memory_stat : bool;
+ print_tags : bool;
+ print_where : bool;
+ print_config: bool;
+ output_context : bool;
+
+ inputstate : string option;
+ outputstate : string option;
+
+}
+
+let init_args = {
+
+ load_init = true;
+ load_rcfile = true;
+ rcfile = None;
+
+ ml_includes = [];
+ vo_includes = [];
+ vo_requires = [];
+
+ batch_mode = false;
+ compilation_mode = BuildVo;
+
+ toplevel_name = Names.(DirPath.make [Id.of_string "Top"]);
+ toploop = None;
+
+ compile_list = [];
+ compilation_output_name = None;
+
+ load_vernacular_list = [];
+
+ vio_checking = false;
+ vio_tasks = [];
+ vio_files = [];
+ vio_files_j = 0;
+
+ color = `AUTO;
+
+ impredicative_set = Declarations.PredicativeSet;
+ stm_flags = Stm.AsyncOpts.default_opts;
+ debug = false;
+ time = false;
+
+ filter_opts = false;
+
+ glob_opt = false;
+
+ memory_stat = false;
+ print_tags = false;
+ print_where = false;
+ print_config = false;
+ output_context = false;
+
+ inputstate = None;
+ outputstate = None;
+}
+
+(******************************************************************************)
+(* Functional arguments *)
+(******************************************************************************)
+let add_ml_include opts s =
+ { opts with ml_includes = s :: opts.ml_includes }
+
+let add_vo_include opts d p implicit =
+ let p = Libnames.dirpath_of_string p in
+ { opts with vo_includes = (d, p, implicit) :: opts.vo_includes }
+
+let add_vo_require opts d p export =
+ { opts with vo_requires = (d, p, export) :: opts.vo_requires }
+
+let add_compat_require opts v =
+ match v with
+ | Flags.V8_6 -> add_vo_require opts "Coq.Compat.Coq86" None (Some false)
+ | Flags.V8_7 -> add_vo_require opts "Coq.Compat.Coq87" None (Some false)
+ | Flags.Current -> add_vo_require opts "Coq.Compat.Coq88" None (Some false)
+
+let set_batch_mode opts =
+ Flags.quiet := true;
+ System.trust_file_cache := true;
+ { opts with batch_mode = true }
+
+let add_compile opts verbose s =
+ let opts = set_batch_mode opts in
+ if not opts.glob_opt then Dumpglob.dump_to_dotglob ();
+ (** make the file name explicit; needed not to break up Coq loadpath stuff. *)
+ let s =
+ let open Filename in
+ if is_implicit s
+ then concat current_dir_name s
+ else s
+ in
+ { opts with compile_list = (s,verbose) :: opts.compile_list }
+
+let add_load_vernacular opts verb s =
+ { opts with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.load_vernacular_list }
+
+let add_vio_task opts f =
+ let opts = set_batch_mode opts in
+ { opts with vio_tasks = f :: opts.vio_tasks }
+
+let add_vio_file opts f =
+ let opts = set_batch_mode opts in
+ { opts with vio_files = f :: opts.vio_files }
+
+let set_vio_checking_j opts opt j =
+ try { opts with vio_files_j = int_of_string j }
+ with Failure _ ->
+ prerr_endline ("The first argument of " ^ opt ^ " must the number");
+ prerr_endline "of concurrent workers to be used (a positive integer).";
+ prerr_endline "Makefiles generated by coq_makefile should be called";
+ prerr_endline "setting the J variable like in 'make vio2vo J=3'";
+ exit 1
+
+(** Options for proof general *)
+let set_emacs opts =
+ if not (Option.is_empty opts.toploop) then
+ CErrors.user_err Pp.(str "Flag -emacs is incompatible with a custom toplevel loop");
+ Coqloop.print_emacs := true;
+ Printer.enable_goal_tags_printing := true;
+ { opts with color = `OFF }
+
+let set_color opts = function
+| "yes" | "on" -> { opts with color = `ON }
+| "no" | "off" -> { opts with color = `OFF }
+| "auto" -> { opts with color = `AUTO }
+| _ -> prerr_endline ("Error: on/off/auto expected after option color"); exit 1
+
+let warn_deprecated_inputstate =
+ CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated"
+ (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.")
+
+let set_inputstate opts s =
+ warn_deprecated_inputstate ();
+ { opts with inputstate = Some s }
+
+let warn_deprecated_outputstate =
+ CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated"
+ (fun () ->
+ Pp.strbrk "The outputstate option is deprecated and discouraged.")
+
+let set_outputstate opts s =
+ warn_deprecated_outputstate ();
+ { opts with outputstate = Some s }
+
+let exitcode opts = if opts.filter_opts then 2 else 0
+
+(******************************************************************************)
+(* Parsing helpers *)
+(******************************************************************************)
+let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s)
+
+let get_bool opt = function
+ | "yes" | "on" -> true
+ | "no" | "off" -> false
+ | _ -> prerr_endline ("Error: yes/no expected after option "^opt); exit 1
+
+let get_int opt n =
+ try int_of_string n
+ with Failure _ ->
+ prerr_endline ("Error: integer expected after option "^opt); exit 1
+
+let get_float opt n =
+ try float_of_string n
+ with Failure _ ->
+ prerr_endline ("Error: float expected after option "^opt); exit 1
+
+let get_host_port opt s =
+ match CString.split ':' s with
+ | [host; portr; portw] ->
+ Some (Spawned.Socket(host, int_of_string portr, int_of_string portw))
+ | ["stdfds"] -> Some Spawned.AnonPipe
+ | _ ->
+ prerr_endline ("Error: host:portr:portw or stdfds expected after option "^opt);
+ exit 1
+
+let get_error_resilience opt = function
+ | "on" | "all" | "yes" -> `All
+ | "off" | "no" -> `None
+ | s -> `Only (CString.split ',' s)
+
+let get_priority opt s =
+ try CoqworkmgrApi.priority_of_string s
+ with Invalid_argument _ ->
+ prerr_endline ("Error: low/high expected after "^opt); exit 1
+
+let get_async_proofs_mode opt = let open Stm.AsyncOpts in function
+ | "no" | "off" -> APoff
+ | "yes" | "on" -> APon
+ | "lazy" -> APonLazy
+ | _ -> prerr_endline ("Error: on/off/lazy expected after "^opt); exit 1
+
+let get_cache opt = function
+ | "force" -> Some Stm.AsyncOpts.Force
+ | _ -> prerr_endline ("Error: force expected after "^opt); exit 1
+
+let get_identifier opt s =
+ try Names.Id.of_string s
+ with CErrors.UserError _ ->
+ prerr_endline ("Error: valid identifier expected after option "^opt); exit 1
+
+let is_not_dash_option = function
+ | Some f when String.length f > 0 && f.[0] <> '-' -> true
+ | _ -> false
+
+let rec add_vio_args peek next oval =
+ if is_not_dash_option (peek ()) then
+ let oval = add_vio_file oval (next ()) in
+ add_vio_args peek next oval
+ else oval
+
+let get_native_name s =
+ (* We ignore even critical errors because this mode has to be super silent *)
+ try
+ String.concat "/" [Filename.dirname s;
+ Nativelib.output_dir; Library.native_name_from_filename s]
+ with _ -> ""
+
+(*s Parsing of the command line.
+ We no longer use [Arg.parse], in order to use share [Usage.print_usage]
+ between coqtop and coqc. *)
+
+let usage_no_coqlib = CWarnings.create ~name:"usage-no-coqlib" ~category:"filesystem"
+ (fun () -> Pp.str "cannot guess a path for Coq libraries; dynaminally loaded flags will not be mentioned")
+
+exception NoCoqLib
+
+let usage batch =
+ begin
+ try Envars.set_coqlib ~fail:(fun x -> raise NoCoqLib)
+ with NoCoqLib -> usage_no_coqlib ()
+ end;
+ let lp = Coqinit.toplevel_init_load_path () in
+ (* Necessary for finding the toplevels below *)
+ List.iter Mltop.add_coq_path lp;
+ if batch then Usage.print_usage_coqc ()
+ else begin
+ Mltop.load_ml_objects_raw_rex
+ (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$"));
+ Usage.print_usage_coqtop ()
+ end
+
+(* Main parsing routine *)
+let parse_args arglist : coq_cmdopts * string list =
+ let args = ref arglist in
+ let extras = ref [] in
+ let rec parse oval = match !args with
+ | [] ->
+ (oval, List.rev !extras)
+ | opt :: rem ->
+ args := rem;
+ let next () = match !args with
+ | x::rem -> args := rem; x
+ | [] -> error_missing_arg opt
+ in
+ let peek_next () = match !args with
+ | x::_ -> Some x
+ | [] -> None
+ in
+ let noval = begin match opt with
+
+ (* Complex options with many args *)
+ |"-I"|"-include" ->
+ begin match rem with
+ | d :: rem ->
+ args := rem;
+ add_ml_include oval d
+ | [] -> error_missing_arg opt
+ end
+ |"-Q" ->
+ begin match rem with
+ | d :: p :: rem ->
+ args := rem;
+ add_vo_include oval d p false
+ | _ -> error_missing_arg opt
+ end
+ |"-R" ->
+ begin match rem with
+ | d :: p :: rem ->
+ args := rem;
+ add_vo_include oval d p true
+ | _ -> error_missing_arg opt
+ end
+
+ (* Options with two arg *)
+ |"-check-vio-tasks" ->
+ let tno = get_task_list (next ()) in
+ let tfile = next () in
+ add_vio_task oval (tno,tfile)
+
+ |"-schedule-vio-checking" ->
+ let oval = { oval with vio_checking = true } in
+ let oval = set_vio_checking_j oval opt (next ()) in
+ let oval = add_vio_file oval (next ()) in
+ add_vio_args peek_next next oval
+
+ |"-schedule-vio2vo" ->
+ let oval = set_vio_checking_j oval opt (next ()) in
+ let oval = add_vio_file oval (next ()) in
+ add_vio_args peek_next next oval
+
+ (* Options with one arg *)
+ |"-coqlib" ->
+ Flags.coqlib_spec := true;
+ Flags.coqlib := (next ());
+ oval
+
+ |"-async-proofs" ->
+ { oval with stm_flags = { oval.stm_flags with
+ Stm.AsyncOpts.async_proofs_mode = get_async_proofs_mode opt (next())
+ }}
+ |"-async-proofs-j" ->
+ { oval with stm_flags = { oval.stm_flags with
+ Stm.AsyncOpts.async_proofs_n_workers = (get_int opt (next ()))
+ }}
+ |"-async-proofs-cache" ->
+ { oval with stm_flags = { oval.stm_flags with
+ Stm.AsyncOpts.async_proofs_cache = get_cache opt (next ())
+ }}
+
+ |"-async-proofs-tac-j" ->
+ { oval with stm_flags = { oval.stm_flags with
+ Stm.AsyncOpts.async_proofs_n_tacworkers = (get_int opt (next ()))
+ }}
+
+ |"-async-proofs-worker-priority" ->
+ WorkerLoop.async_proofs_worker_priority := get_priority opt (next ());
+ oval
+
+ |"-async-proofs-private-flags" ->
+ { oval with stm_flags = { oval.stm_flags with
+ Stm.AsyncOpts.async_proofs_private_flags = Some (next ());
+ }}
+
+ |"-async-proofs-tactic-error-resilience" ->
+ { oval with stm_flags = { oval.stm_flags with
+ Stm.AsyncOpts.async_proofs_tac_error_resilience = get_error_resilience opt (next ())
+ }}
+
+ |"-async-proofs-command-error-resilience" ->
+ { oval with stm_flags = { oval.stm_flags with
+ Stm.AsyncOpts.async_proofs_cmd_error_resilience = get_bool opt (next ())
+ }}
+
+ |"-async-proofs-delegation-threshold" ->
+ { oval with stm_flags = { oval.stm_flags with
+ Stm.AsyncOpts.async_proofs_delegation_threshold = get_float opt (next ())
+ }}
+
+ |"-worker-id" -> set_worker_id opt (next ()); oval
+
+ |"-compat" ->
+ let v = G_vernac.parse_compat_version ~allow_old:false (next ()) in
+ Flags.compat_version := v;
+ add_compat_require oval v
+
+ |"-compile" ->
+ add_compile oval false (next ())
+
+ |"-compile-verbose" ->
+ add_compile oval true (next ())
+
+ |"-dump-glob" ->
+ Dumpglob.dump_into_file (next ());
+ { oval with glob_opt = true }
+
+ |"-feedback-glob" ->
+ Dumpglob.feedback_glob (); oval
+
+ |"-exclude-dir" ->
+ System.exclude_directory (next ()); oval
+
+ |"-init-file" ->
+ { oval with rcfile = Some (next ()); }
+
+ |"-inputstate"|"-is" ->
+ set_inputstate oval (next ())
+
+ |"-outputstate" ->
+ set_outputstate oval (next ())
+
+ |"-load-ml-object" ->
+ Mltop.dir_ml_load (next ()); oval
+
+ |"-load-ml-source" ->
+ Mltop.dir_ml_use (next ()); oval
+
+ |"-load-vernac-object" ->
+ add_vo_require oval (next ()) None None
+
+ |"-load-vernac-source"|"-l" ->
+ add_load_vernacular oval false (next ())
+
+ |"-load-vernac-source-verbose"|"-lv" ->
+ add_load_vernacular oval true (next ())
+
+ |"-mangle-names" ->
+ Namegen.set_mangle_names_mode (get_identifier opt (next ())); oval
+
+ |"-print-mod-uid" ->
+ let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0
+
+ |"-profile-ltac-cutoff" ->
+ Flags.profile_ltac := true;
+ Flags.profile_ltac_cutoff := get_float opt (next ());
+ oval
+
+ |"-require" -> add_vo_require oval (next ()) None (Some false)
+
+ |"-top" ->
+ let topname = Libnames.dirpath_of_string (next ()) in
+ if Names.DirPath.is_empty topname then
+ CErrors.user_err Pp.(str "Need a non empty toplevel module name");
+ { oval with toplevel_name = topname }
+
+ |"-main-channel" ->
+ Spawned.main_channel := get_host_port opt (next()); oval
+
+ |"-control-channel" ->
+ Spawned.control_channel := get_host_port opt (next()); oval
+
+ |"-vio2vo" ->
+ let oval = add_compile oval false (next ()) in
+ { oval with compilation_mode = Vio2Vo }
+
+ |"-toploop" ->
+ if !Coqloop.print_emacs then
+ CErrors.user_err Pp.(str "Flags -toploop and -emacs are incompatible");
+ { oval with toploop = Some (next ()) }
+
+ |"-w" | "-W" ->
+ let w = next () in
+ if w = "none" then
+ (CWarnings.set_flags w; oval)
+ else
+ let w = CWarnings.get_flags () ^ "," ^ w in
+ CWarnings.set_flags (CWarnings.normalize_flags_string w);
+ oval
+
+ |"-o" -> { oval with compilation_output_name = Some (next()) }
+
+ (* Options with zero arg *)
+ |"-async-queries-always-delegate"
+ |"-async-proofs-always-delegate"
+ |"-async-proofs-full" ->
+ { oval with stm_flags = { oval.stm_flags with
+ Stm.AsyncOpts.async_proofs_full = true;
+ }}
+ |"-async-proofs-never-reopen-branch" ->
+ { oval with stm_flags = { oval.stm_flags with
+ Stm.AsyncOpts.async_proofs_never_reopen_branch = true
+ }}
+ |"-batch" -> set_batch_mode oval
+ |"-test-mode" -> Flags.test_mode := true; oval
+ |"-beautify" -> Flags.beautify := true; oval
+ |"-boot" -> Flags.boot := true; { oval with load_rcfile = false; }
+ |"-bt" -> Backtrace.record_backtrace true; oval
+ |"-color" -> set_color oval (next ())
+ |"-config"|"--config" -> { oval with print_config = true }
+ |"-debug" -> Coqinit.set_debug (); oval
+ |"-stm-debug" -> Stm.stm_debug := true; oval
+ |"-emacs" -> set_emacs oval
+ |"-filteropts" -> { oval with filter_opts = true }
+ |"-ideslave" ->
+ if !Coqloop.print_emacs then
+ CErrors.user_err Pp.(str "Flags -ideslave and -emacs are incompatible");
+ Flags.ide_slave := true;
+ { oval with toploop = Some "coqidetop" }
+
+ |"-impredicative-set" ->
+ { oval with impredicative_set = Declarations.ImpredicativeSet }
+ |"-indices-matter" -> Indtypes.enforce_indices_matter (); oval
+ |"-m"|"--memory" -> { oval with memory_stat = true }
+ |"-noinit"|"-nois" -> { oval with load_init = false }
+ |"-no-glob"|"-noglob" -> Dumpglob.noglob (); { oval with glob_opt = true }
+ |"-native-compiler" ->
+ if not Coq_config.native_compiler then
+ warning "Native compilation was disabled at configure time."
+ else Flags.output_native_objects := true; oval
+ |"-output-context" -> { oval with output_context = true }
+ |"-profile-ltac" -> Flags.profile_ltac := true; oval
+ |"-q" -> { oval with load_rcfile = false; }
+ |"-quiet"|"-silent" ->
+ Flags.quiet := true;
+ Flags.make_warn false;
+ oval
+ |"-quick" -> { oval with compilation_mode = BuildVio }
+ |"-list-tags" -> { oval with print_tags = true }
+ |"-time" -> { oval with time = true }
+ |"-type-in-type" -> set_type_in_type (); oval
+ |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false)
+ |"-where" -> { oval with print_where = true }
+ |"-h"|"-H"|"-?"|"-help"|"--help" -> usage oval.batch_mode; oval
+ |"-v"|"--version" -> Usage.version (exitcode oval)
+ |"-print-version"|"--print-version" ->
+ Usage.machine_readable_version (exitcode oval)
+
+ (* Unknown option *)
+ | s ->
+ extras := s :: !extras;
+ oval
+ end in
+ parse noval
+ in
+ try
+ parse init_args
+ with any -> fatal_error any
diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli
new file mode 100644
index 00000000..de9b6a68
--- /dev/null
+++ b/toplevel/coqargs.mli
@@ -0,0 +1,65 @@
+(************************************************************************)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
+(************************************************************************)
+
+type compilation_mode = BuildVo | BuildVio | Vio2Vo
+type color = [`ON | `AUTO | `OFF]
+
+type coq_cmdopts = {
+
+ load_init : bool;
+ load_rcfile : bool;
+ rcfile : string option;
+
+ ml_includes : string list;
+ vo_includes : (string * Names.DirPath.t * bool) list;
+ vo_requires : (string * string option * bool option) list;
+
+ (* Fuse these two? Currently, [batch_mode] is only used to
+ distinguish coqc / coqtop in help display. *)
+ batch_mode : bool;
+ compilation_mode : compilation_mode;
+
+ toplevel_name : Names.DirPath.t;
+ toploop : string option;
+
+ compile_list: (string * bool) list; (* bool is verbosity *)
+ compilation_output_name : string option;
+
+ load_vernacular_list : (string * bool) list;
+
+ vio_checking: bool;
+ vio_tasks : (int list * string) list;
+ vio_files : string list;
+ vio_files_j : int;
+
+ color : color;
+
+ impredicative_set : Declarations.set_predicativity;
+ stm_flags : Stm.AsyncOpts.stm_opt;
+ debug : bool;
+ time : bool;
+
+ filter_opts : bool;
+
+ glob_opt : bool;
+
+ memory_stat : bool;
+ print_tags : bool;
+ print_where : bool;
+ print_config: bool;
+ output_context : bool;
+
+ inputstate : string option;
+ outputstate : string option;
+
+}
+
+val parse_args : string list -> coq_cmdopts * string list
+val exitcode : coq_cmdopts -> int
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index acbf909c..96a0bd5e 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -1,9 +1,11 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
open Util
@@ -20,21 +22,15 @@ let set_debug () =
does not exist. *)
let rcdefaultname = "coqrc"
-let rcfile = ref ""
-let rcfile_specified = ref false
-let set_rcfile s = rcfile := s; rcfile_specified := true
-let load_rc = ref true
-let no_load_rc () = load_rc := false
-
-let load_rcfile() =
- if !load_rc then
+let load_rcfile ~rcfile ~time ~state =
try
- if !rcfile_specified then
- if CUnix.file_readable_p !rcfile then
- Vernac.load_vernac false !rcfile
- else raise (Sys_error ("Cannot read rcfile: "^ !rcfile))
- else
+ match rcfile with
+ | Some rcfile ->
+ if CUnix.file_readable_p rcfile then
+ Vernac.load_vernac ~time ~echo:false ~interactive:false ~check:true ~state rcfile
+ else raise (Sys_error ("Cannot read rcfile: "^ rcfile))
+ | None ->
try
let warn x = Feedback.msg_warning (str x) in
let inferedrc = List.find CUnix.file_readable_p [
@@ -43,8 +39,8 @@ let load_rcfile() =
Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version;
Envars.home ~warn / "."^rcdefaultname
] in
- Vernac.load_vernac false inferedrc
- with Not_found -> ()
+ Vernac.load_vernac ~time ~echo:false ~interactive:false ~check:true ~state inferedrc
+ with Not_found -> state
(*
Flags.if_verbose
mSGNL (str ("No coqrc or coqrc."^Coq_config.version^
@@ -54,89 +50,79 @@ let load_rcfile() =
let reraise = CErrors.push reraise in
let () = Feedback.msg_info (str"Load of rcfile failed.") in
iraise reraise
- else
- Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading.")
(* Recursively puts dir in the LoadPath if -nois was not passed *)
-let add_stdlib_path ~unix_path ~coq_root ~with_ml =
- let add_ml = if with_ml then Mltop.AddRecML else Mltop.AddNoML in
- Mltop.add_rec_path add_ml ~unix_path ~coq_root ~implicit:(!Flags.load_init)
-
-let add_userlib_path ~unix_path =
- Mltop.add_rec_path Mltop.AddRecML ~unix_path
- ~coq_root:Nameops.default_root_prefix ~implicit:false
-
-(* Options -I, -I-as, and -R of the command line *)
-let includes = ref []
-let push_include s alias implicit =
- includes := (s, alias, implicit) :: !includes
-let ml_includes = ref []
-let push_ml_include s = ml_includes := s :: !ml_includes
-
-(* Initializes the LoadPath *)
-let init_load_path () =
+let build_stdlib_path ~load_init ~unix_path ~coq_path ~with_ml =
+ let open Mltop in
+ let add_ml = if with_ml then AddRecML else AddNoML in
+ { recursive = true;
+ path_spec = VoPath { unix_path; coq_path ; has_ml = add_ml; implicit = load_init }
+ }
+
+let build_userlib_path ~unix_path =
+ let open Mltop in
+ { recursive = true;
+ path_spec = VoPath {
+ unix_path;
+ coq_path = Libnames.default_root_prefix;
+ has_ml = Mltop.AddRecML;
+ implicit = false;
+ }
+ }
+
+let ml_path_if c p =
+ let open Mltop in
+ let f x = { recursive = false; path_spec = MlPath x } in
+ if c then List.map f p else []
+
+(* LoadPath for toploop toplevels *)
+let toplevel_init_load_path () =
+ let coqlib = Envars.coqlib () in
+ (* NOTE: These directories are searched from last to first *)
+ (* first, developer specific directory to open *)
+ ml_path_if Coq_config.local [coqlib/"dev"] @
+
+ (* main loops *)
+ ml_path_if (Coq_config.local || !Flags.boot) [coqlib/"stm"; coqlib/"ide"] @
+ ml_path_if (System.exists_dir (coqlib/"toploop")) [coqlib/"toploop"]
+
+(* LoadPath for Coq user libraries *)
+let libs_init_load_path ~load_init =
+
+ let open Mltop in
let coqlib = Envars.coqlib () in
let user_contrib = coqlib/"user-contrib" in
let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x)) in
let coqpath = Envars.coqpath in
- let coq_root = Names.DirPath.make [Nameops.coq_root] in
- (* NOTE: These directories are searched from last to first *)
- (* first, developer specific directory to open *)
- if Coq_config.local then
- Mltop.add_ml_dir (coqlib/"dev");
- (* main loops *)
- if Coq_config.local || !Flags.boot then begin
- Mltop.add_ml_dir (coqlib/"stm");
- Mltop.add_ml_dir (coqlib/"ide")
- end;
- if System.exists_dir (coqlib/"toploop") then
- Mltop.add_ml_dir (coqlib/"toploop");
- (* then standard library *)
- add_stdlib_path ~unix_path:(coqlib/"theories") ~coq_root ~with_ml:false;
- (* then plugins *)
- add_stdlib_path ~unix_path:(coqlib/"plugins") ~coq_root ~with_ml:true;
- (* then user-contrib *)
- if Sys.file_exists user_contrib then
- add_userlib_path ~unix_path:user_contrib;
- (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *)
- List.iter (fun s -> add_userlib_path ~unix_path:s) xdg_dirs;
- (* then directories in COQPATH *)
- List.iter (fun s -> add_userlib_path ~unix_path:s) coqpath;
- (* then current directory (not recursively!) *)
- Mltop.add_ml_dir ".";
- Loadpath.add_load_path "." Nameops.default_root_prefix ~implicit:false;
- (* additional loadpath, given with options -Q and -R *)
- List.iter
- (fun (unix_path, coq_root, implicit) ->
- Mltop.add_rec_path Mltop.AddNoML ~unix_path ~coq_root ~implicit)
- (List.rev !includes);
- (* additional ml directories, given with option -I *)
- List.iter Mltop.add_ml_dir (List.rev !ml_includes)
-
-let init_library_roots () =
- includes := []
+ let coq_path = Names.DirPath.make [Libnames.coq_root] in
+
+ (* then standard library and plugins *)
+ [build_stdlib_path ~load_init ~unix_path:(coqlib/"theories") ~coq_path ~with_ml:false;
+ build_stdlib_path ~load_init ~unix_path:(coqlib/"plugins") ~coq_path ~with_ml:true ] @
+
+ (* then user-contrib *)
+ (if Sys.file_exists user_contrib then
+ [build_userlib_path ~unix_path:user_contrib] else []
+ ) @
+
+ (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME and COQPATH *)
+ List.map (fun s -> build_userlib_path ~unix_path:s) (xdg_dirs @ coqpath) @
+
+ (* then current directory (not recursively!) *)
+ [ { recursive = false;
+ path_spec = VoPath { unix_path = ".";
+ coq_path = Libnames.default_root_prefix;
+ implicit = false;
+ has_ml = AddTopML }
+ } ]
(* Initialises the Ocaml toplevel before launching it, so that it can
find the "include" file in the *source* directory *)
let init_ocaml_path () =
+ let open Mltop in
+ let lp s = { recursive = false; path_spec = MlPath s } in
let add_subdir dl =
- Mltop.add_ml_dir (List.fold_left (/) Envars.coqroot dl)
+ Mltop.add_coq_path (lp (List.fold_left (/) Envars.coqroot [dl]))
in
- Mltop.add_ml_dir (Envars.coqlib ());
- List.iter add_subdir
- [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ];
- [ "engine" ]; [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
- [ "tactics" ]; [ "toplevel" ]; [ "printing" ]; [ "intf" ];
- [ "grammar" ]; [ "ide" ]; [ "ltac" ]; ]
-
-let get_compat_version = function
- | "8.6" -> Flags.Current
- | "8.5" -> Flags.V8_5
- | "8.4" -> Flags.V8_4
- | "8.3" -> Flags.V8_3
- | "8.2" -> Flags.V8_2
- | ("8.1" | "8.0") as s ->
- CErrors.errorlabstrm "get_compat_version"
- (str "Compatibility with version " ++ str s ++ str " not supported.")
- | s -> CErrors.errorlabstrm "get_compat_version"
- (str "Unknown compatibility version \"" ++ str s ++ str "\".")
+ Mltop.add_coq_path (lp (Envars.coqlib ()));
+ List.iter add_subdir Coq_config.all_src_dirs
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
index 4ff87628..71b5523c 100644
--- a/toplevel/coqinit.mli
+++ b/toplevel/coqinit.mli
@@ -1,28 +1,23 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
(** Initialization. *)
val set_debug : unit -> unit
-val set_rcfile : string -> unit
-
-val no_load_rc : unit -> unit
-val load_rcfile : unit -> unit
-
-val push_include : string -> Names.DirPath.t -> bool -> unit
-(** [push_include phys_path log_path implicit] *)
-
-val push_ml_include : string -> unit
-
-val init_load_path : unit -> unit
-val init_library_roots : unit -> unit
+val load_rcfile : rcfile:(string option) -> time:bool -> state:Vernac.State.t -> Vernac.State.t
val init_ocaml_path : unit -> unit
-val get_compat_version : string -> Flags.compat_version
+(* LoadPath for toploop toplevels *)
+val toplevel_init_load_path : unit -> Mltop.coq_path list
+
+(* LoadPath for Coq user libraries *)
+val libs_init_load_path : load_init:bool -> Mltop.coq_path list
diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml
index e9771cfa..3239d360 100644
--- a/toplevel/coqloop.ml
+++ b/toplevel/coqloop.ml
@@ -1,36 +1,36 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
open Pp
-open CErrors
-open Util
-open Flags
-open Vernac
-open Pcoq
-let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x
+let print_emacs = ref false
+
+let top_stderr x =
+ Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with x
(* A buffer for the character read from a channel. We store the command
* entered to be able to report errors without pretty-printing. *)
type input_buffer = {
- mutable prompt : unit -> string;
- mutable str : string; (* buffer of already read characters *)
+ mutable prompt : Stm.doc -> string;
+ mutable str : Bytes.t; (* buffer of already read characters *)
mutable len : int; (* number of chars in the buffer *)
mutable bols : int list; (* offsets in str of beginning of lines *)
- mutable tokens : Gram.coq_parsable; (* stream of tokens *)
+ mutable tokens : Pcoq.Gram.coq_parsable; (* stream of tokens *)
mutable start : int } (* stream count of the first char of the buffer *)
(* Double the size of the buffer. *)
-let resize_buffer ibuf =
- let nstr = String.create (2 * String.length ibuf.str + 1) in
- String.blit ibuf.str 0 nstr 0 (String.length ibuf.str);
+let resize_buffer ibuf = let open Bytes in
+ let nstr = create (2 * length ibuf.str + 1) in
+ blit ibuf.str 0 nstr 0 (length ibuf.str);
ibuf.str <- nstr
(* Delete all irrelevant lines of the input buffer. Keep the last line
@@ -40,7 +40,7 @@ let resynch_buffer ibuf =
match ibuf.bols with
| ll::_ ->
let new_len = ibuf.len - ll in
- String.blit ibuf.str ll ibuf.str 0 new_len;
+ Bytes.blit ibuf.str ll ibuf.str 0 new_len;
ibuf.len <- new_len;
ibuf.bols <- [];
ibuf.start <- ibuf.start + ll
@@ -49,24 +49,22 @@ let resynch_buffer ibuf =
(* emacs special prompt tag for easy detection. No special character,
to avoid interfering with utf8. Compatibility code removed. *)
-
-let emacs_prompt_startstring() = Printer.emacs_str "<prompt>"
-
-let emacs_prompt_endstring() = Printer.emacs_str "</prompt>"
+let emacs_prompt_startstring () = if !print_emacs then "<prompt>" else ""
+let emacs_prompt_endstring () = if !print_emacs then "</prompt>" else ""
(* Read a char in an input channel, displaying a prompt at every
beginning of line. *)
-let prompt_char ic ibuf count =
+let prompt_char doc ic ibuf count =
let bol = match ibuf.bols with
| ll::_ -> Int.equal ibuf.len ll
| [] -> Int.equal ibuf.len 0
in
- if bol && not !print_emacs then top_stderr (str (ibuf.prompt()));
+ if bol && not !print_emacs then top_stderr (str (ibuf.prompt doc));
try
let c = input_char ic in
if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols;
- if ibuf.len == String.length ibuf.str then resize_buffer ibuf;
- ibuf.str.[ibuf.len] <- c;
+ if ibuf.len == Bytes.length ibuf.str then resize_buffer ibuf;
+ Bytes.set ibuf.str ibuf.len c;
ibuf.len <- ibuf.len + 1;
Some c
with End_of_file ->
@@ -74,21 +72,22 @@ let prompt_char ic ibuf count =
(* Reinitialize the char stream (after a Drop) *)
-let reset_input_buffer ic ibuf =
- ibuf.str <- "";
+let reset_input_buffer doc ic ibuf =
+ ibuf.str <- Bytes.empty;
ibuf.len <- 0;
ibuf.bols <- [];
- ibuf.tokens <- Gram.parsable (Stream.from (prompt_char ic ibuf));
+ ibuf.tokens <- Pcoq.Gram.parsable (Stream.from (prompt_char doc ic ibuf));
ibuf.start <- 0
(* Functions to print underlined locations from an input buffer. *)
+module TopErr = struct
(* Given a location, returns the list of locations of each line. The last
line is returned separately. It also checks the location bounds. *)
let get_bols_of_loc ibuf (bp,ep) =
let add_line (b,e) lines =
- if b < 0 || e < b then anomaly (Pp.str "Bad location");
+ if b < 0 || e < b then CErrors.anomaly (Pp.str "Bad location.");
match lines with
| ([],None) -> ([], Some (b,e))
| (fl,oe) -> ((b,e)::fl, oe)
@@ -109,86 +108,93 @@ let dotted_location (b,e) =
else
(String.make (e-b-1) '.', " ")
-let blanch_utf8_string s bp ep =
- let s' = String.make (ep-bp) ' ' in
+let blanch_utf8_string s bp ep = let open Bytes in
+ let s' = make (ep-bp) ' ' in
let j = ref 0 in
for i = bp to ep - 1 do
- let n = Char.code s.[i] in
+ let n = Char.code (get s i) in
(* Heuristic: assume utf-8 chars are printed using a single
fixed-size char and therefore contract all utf-8 code into one
space; in any case, preserve tabulation so
that its effective interpretation in terms of spacing is preserved *)
- if s.[i] == '\t' then s'.[!j] <- '\t';
+ if get s i == '\t' then set s' !j '\t';
if n < 0x80 || 0xC0 <= n then incr j
done;
- String.sub s' 0 !j
+ Bytes.sub_string s' 0 !j
+
+let adjust_loc_buf ib loc = let open Loc in
+ { loc with ep = loc.ep - ib.start; bp = loc.bp - ib.start }
let print_highlight_location ib loc =
let (bp,ep) = Loc.unloc loc in
- let bp = bp - ib.start
- and ep = ep - ib.start in
let highlight_lines =
match get_bols_of_loc ib (bp,ep) with
| ([],(bl,el)) ->
let shift = blanch_utf8_string ib.str bl bp in
let span = String.length (blanch_utf8_string ib.str bp ep) in
- (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++
+ (str"> " ++ str(Bytes.sub_string ib.str bl (el-bl-1)) ++ fnl () ++
str"> " ++ str(shift) ++ str(String.make span '^'))
| ((b1,e1)::ml,(bn,en)) ->
let (d1,s1) = dotted_location (b1,bp) in
let (dn,sn) = dotted_location (ep,en) in
let l1 = (str"> " ++ str d1 ++ str s1 ++
- str(String.sub ib.str bp (e1-bp))) in
+ str(Bytes.sub_string ib.str bp (e1-bp))) in
let li =
prlist (fun (bi,ei) ->
- (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in
- let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++
+ (str"> " ++ str(Bytes.sub_string ib.str bi (ei-bi)))) ml in
+ let ln = (str"> " ++ str(Bytes.sub_string ib.str bn (ep-bn)) ++
str sn ++ str dn) in
(l1 ++ li ++ ln)
in
- let loc = Loc.make_loc (bp,ep) in
- (Pp.pr_loc loc ++ highlight_lines ++ fnl ())
-
-(* Functions to report located errors in a file. *)
-
-let print_location_in_file loc =
- let fname = loc.Loc.fname in
- let errstrm = str"Error while reading " ++ str fname in
- if Loc.is_ghost loc then
- hov 1 (errstrm ++ spc() ++ str" (unknown location):") ++ fnl ()
- else
- let errstrm = mt ()
- (* if String.equal outer_fname fname then mt() else errstrm ++ str":" ++ fnl() *)
- in
- let open Loc in
- hov 0 (* No line break so as to follow emacs error message format *)
- (errstrm ++ Pp.pr_loc loc)
+ highlight_lines
let valid_buffer_loc ib loc =
- not (Loc.is_ghost loc) &&
let (b,e) = Loc.unloc loc in b-ib.start >= 0 && e-ib.start < ib.len && b<=e
+(* Toplevel error explanation. *)
+let error_info_for_buffer ?loc buf =
+ Option.map (fun loc ->
+ let fname = loc.Loc.fname in
+ let hl, loc =
+ (* We are in the toplevel *)
+ match fname with
+ | Loc.ToplevelInput ->
+ let nloc = adjust_loc_buf buf loc in
+ if valid_buffer_loc buf loc then
+ (fnl () ++ print_highlight_location buf nloc, nloc)
+ (* in the toplevel, but not a valid buffer *)
+ else (mt (), nloc)
+ (* we are in batch mode, don't adjust location *)
+ | Loc.InFile _ ->
+ (mt (), loc)
+ in Topfmt.pr_loc loc ++ hl
+ ) loc
+
+(* Actual printing routine *)
+let print_error_for_buffer ?loc lvl msg buf =
+ let pre_hdr = error_info_for_buffer ?loc buf in
+ if !print_emacs
+ then Topfmt.emacs_logger ?pre_hdr lvl msg
+ else Topfmt.std_logger ?pre_hdr lvl msg
+
+(*
+let print_toplevel_parse_error (e, info) buf =
+ let loc = Loc.get_loc info in
+ let lvl = Feedback.Error in
+ let msg = CErrors.iprint (e, info) in
+ print_error_for_buffer ?loc lvl msg buf
+*)
+end
+
(*s The Coq prompt is the name of the focused proof, if any, and "Coq"
otherwise. We trap all exceptions to prevent the error message printing
from cycling. *)
let make_prompt () =
try
- (Names.Id.to_string (Pfedit.get_current_proof_name ())) ^ " < "
+ (Names.Id.to_string (Proof_global.get_current_proof_name ())) ^ " < "
with Proof_global.NoCurrentProof ->
"Coq < "
-(*let build_pending_list l =
- let pl = ref ">" in
- let l' = ref l in
- let res =
- while List.length !l' > 1 do
- pl := !pl ^ "|" Names.Id.to_string x;
- l':=List.tl !l'
- done in
- let last = try List.hd !l' with _ -> in
- "<"^l'
-*)
-
(* the coq prompt added to the default one when in emacs mode
The prompt contains the current state label [n] (for global
backtracking) and the current proof state [p] (for proof
@@ -197,70 +203,50 @@ let make_prompt () =
"n |lem1|lem2|lem3| p < "
*)
-let make_emacs_prompt() =
- let statnum = Stateid.to_string (Stm.get_current_state ()) in
- let dpth = Stm.current_proof_depth() in
- let pending = Stm.get_all_proof_names() in
+let make_emacs_prompt doc =
+ let statnum = Stateid.to_string (Stm.get_current_state ~doc) in
+ let dpth = Stm.current_proof_depth ~doc in
+ let pending = Stm.get_all_proof_names ~doc in
let pendingprompt =
List.fold_left
- (fun acc x -> acc ^ (if String.is_empty acc then "" else "|") ^ Names.Id.to_string x)
+ (fun acc x -> acc ^ (if CString.is_empty acc then "" else "|") ^ Names.Id.to_string x)
"" pending in
let proof_info = if dpth >= 0 then string_of_int dpth else "0" in
- if !Flags.print_emacs then statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < "
+ if !print_emacs then statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < "
else ""
(* A buffer to store the current command read on stdin. It is
* initialized when a vernac command is immediately followed by "\n",
* or after a Drop. *)
let top_buffer =
- let pr() =
+ let pr doc =
emacs_prompt_startstring()
^ make_prompt()
- ^ make_emacs_prompt()
+ ^ make_emacs_prompt doc
^ emacs_prompt_endstring()
in
{ prompt = pr;
- str = "";
+ str = Bytes.empty;
len = 0;
bols = [];
- tokens = Gram.parsable (Stream.of_list []);
+ tokens = Pcoq.Gram.parsable (Stream.of_list []);
start = 0 }
let set_prompt prompt =
top_buffer.prompt
- <- (fun () ->
+ <- (fun doc ->
emacs_prompt_startstring()
^ prompt ()
^ emacs_prompt_endstring())
-(* The following exceptions need not be located. *)
-
-let locate_exn = function
- | Out_of_memory | Stack_overflow | Sys.Break -> false
- | _ -> true
-
-(* Toplevel error explanation. *)
-
-let print_toplevel_error (e, info) =
- let loc = Option.default Loc.ghost (Loc.get_loc info) in
- let fname = loc.Loc.fname in
- let locmsg =
- if Loc.is_ghost loc || String.equal fname "" then
- if locate_exn e && valid_buffer_loc top_buffer loc then
- print_highlight_location top_buffer loc
- else mt ()
- else print_location_in_file loc
- in
- locmsg ++ CErrors.iprint (e, info)
-
(* Read the input stream until a dot is encountered *)
let parse_to_dot =
- let rec dot st = match Compat.get_tok (Stream.next st) with
+ let rec dot st = match Stream.next st with
| Tok.KEYWORD ("."|"...") -> ()
- | Tok.EOI -> raise End_of_input
+ | Tok.EOI -> raise Stm.End_of_input
| _ -> dot st
in
- Gram.Entry.of_parser "Coqtoplevel.dot" dot
+ Pcoq.Gram.Entry.of_parser "Coqtoplevel.dot" dot
(* If an error occurred while parsing, we try to read the input until a dot
token is encountered.
@@ -268,20 +254,56 @@ let parse_to_dot =
let rec discard_to_dot () =
try
- Gram.entry_parse parse_to_dot top_buffer.tokens
+ Pcoq.Gram.entry_parse parse_to_dot top_buffer.tokens
with
- | Compat.Token.Error _ | CLexer.Error.E _ -> discard_to_dot ()
- | End_of_input -> raise End_of_input
+ | Token.Error _ | CLexer.Error.E _ -> discard_to_dot ()
+ | Stm.End_of_input -> raise Stm.End_of_input
| e when CErrors.noncritical e -> ()
-let read_sentence input =
- try
- let (loc, _ as r) = Vernac.parse_sentence input in
- CWarnings.set_current_loc loc; r
+let read_sentence ~state input =
+ let open Vernac.State in
+ try Stm.parse_sentence ~doc:state.doc state.sid input
with reraise ->
let reraise = CErrors.push reraise in
discard_to_dot ();
- iraise reraise
+ (* The caller of read_sentence does the error printing now, this
+ should be re-enabled once we rely on the feedback error
+ printer again *)
+ (* TopErr.print_toplevel_parse_error reraise top_buffer; *)
+ Exninfo.iraise reraise
+
+let extract_default_loc loc doc_id sid : Loc.t option =
+ match loc with
+ | Some _ -> loc
+ | None ->
+ try
+ let doc = Stm.get_doc doc_id in
+ Option.cata fst None Stm.(get_ast ~doc sid)
+ with _ -> loc
+
+(** Coqloop Console feedback handler *)
+let coqloop_feed (fb : Feedback.feedback) = let open Feedback in
+ match fb.contents with
+ | Processed -> ()
+ | Incomplete -> ()
+ | Complete -> ()
+ | ProcessingIn _ -> ()
+ | InProgress _ -> ()
+ | WorkerStatus (_,_) -> ()
+ | AddedAxiom -> ()
+ | GlobRef (_,_,_,_,_) -> ()
+ | GlobDef (_,_,_,_) -> ()
+ | FileDependency (_,_) -> ()
+ | FileLoaded (_,_) -> ()
+ | Custom (_,_,_) -> ()
+ (* Re-enable when we switch back to feedback-based error printing *)
+ | Message (Error,loc,msg) -> ()
+ (* TopErr.print_error_for_buffer ?loc lvl msg top_buffer *)
+ | Message (Warning,loc,msg) ->
+ let loc = extract_default_loc loc fb.doc_id fb.span_id in
+ TopErr.print_error_for_buffer ?loc Warning msg top_buffer
+ | Message (lvl,loc,msg) ->
+ TopErr.print_error_for_buffer ?loc lvl msg top_buffer
(** [do_vernac] reads and executes a toplevel phrase, and print error
messages when an exception is raised, except for the following:
@@ -293,24 +315,29 @@ let read_sentence input =
is caught and handled (i.e. not re-raised).
*)
-let do_vernac () =
+let do_vernac ~time ~state =
+ let open Vernac.State in
top_stderr (fnl());
- if !print_emacs then top_stderr (str (top_buffer.prompt()));
+ if !print_emacs then top_stderr (str (top_buffer.prompt state.doc));
resynch_buffer top_buffer;
try
let input = (top_buffer.tokens, None) in
- Vernac.process_expr top_buffer.tokens (read_sentence input)
+ Vernac.process_expr ~time ~state (read_sentence ~state (fst input))
with
- | End_of_input | CErrors.Quit ->
+ | Stm.End_of_input | CErrors.Quit ->
top_stderr (fnl ()); raise CErrors.Quit
| CErrors.Drop -> (* Last chance *)
if Mltop.is_ocaml_top() then raise CErrors.Drop
- else Feedback.msg_error (str"There is no ML toplevel.")
+ else (Feedback.msg_warning (str "There is no ML toplevel."); state)
+ (* Exception printing should be done by the feedback listener,
+ however this is not yet ready so we rely on the exception for
+ now. *)
| any ->
- let any = CErrors.push any in
- let msg = print_toplevel_error any ++ fnl () in
- pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft msg;
- Format.pp_print_flush !Pp_control.std_ft ()
+ let (e, info) = CErrors.push any in
+ let loc = Loc.get_loc info in
+ let msg = CErrors.iprint (e, info) in
+ TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer;
+ state
(** Main coq loop : read vernacular expressions until Drop is entered.
Ctrl-C is handled internally as Sys.Break instead of aborting Coq.
@@ -318,37 +345,77 @@ let do_vernac () =
exit the loop are Drop and Quit. Any other exception there indicates
an issue with [print_toplevel_error] above. *)
-(*
-let feed_emacs = function
- | { Interface.id = Interface.State id;
- Interface.content = Interface.GlobRef (_,a,_,c,_) } ->
- prerr_endline ("<info>" ^"<id>"^Stateid.to_string id ^"</id>"
- ^a^" "^c^ "</info>")
- | _ -> ()
-*)
-
(* Flush in a compatible order with 8.5 *)
(* This mimics the semantics of the old Pp.flush_all *)
let loop_flush_all () =
Pervasives.flush stderr;
Pervasives.flush stdout;
- Format.pp_print_flush !Pp_control.std_ft ();
- Format.pp_print_flush !Pp_control.err_ft ()
+ Format.pp_print_flush !Topfmt.std_ft ();
+ Format.pp_print_flush !Topfmt.err_ft ()
+
+let pr_open_cur_subgoals () =
+ try
+ let proof = Proof_global.give_me_the_proof () in
+ Printer.pr_open_subgoals ~proof
+ with Proof_global.NoCurrentProof -> Pp.str ""
+
+(* Goal equality heuristic. *)
+let pequal cmp1 cmp2 (a1,a2) (b1,b2) = cmp1 a1 b1 && cmp2 a2 b2
+let evleq e1 e2 = CList.equal Evar.equal e1 e2
+let cproof p1 p2 =
+ let (a1,a2,a3,a4,_),(b1,b2,b3,b4,_) = Proof.proof p1, Proof.proof p2 in
+ evleq a1 b1 &&
+ CList.equal (pequal evleq evleq) a2 b2 &&
+ CList.equal Evar.equal a3 b3 &&
+ CList.equal Evar.equal a4 b4
+
+(* We try to behave better when goal printing raises an exception
+ [usually Ctrl-C]
+
+ This is mostly a hack as we should protect printing in a more
+ generic way, but that'll do for now *)
+let top_goal_print oldp newp =
+ try
+ let proof_changed = not (Option.equal cproof oldp newp) in
+ let print_goals = not !Flags.quiet &&
+ proof_changed && Proof_global.there_are_pending_proofs () in
+ if print_goals then Feedback.msg_notice (pr_open_cur_subgoals ())
+ with
+ | CErrors.Drop | CErrors.Quit as exn -> raise exn
+ | exn ->
+ let (e, info) = CErrors.push exn in
+ let loc = Loc.get_loc info in
+ let msg = CErrors.iprint (e, info) in
+ TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer
+
+let drop_last_doc = ref None
-let rec loop () =
+let rec loop ~time ~state =
+ let open Vernac.State in
Sys.catch_break true;
- if !Flags.print_emacs then Vernacentries.qed_display_script := false;
- Flags.coqtop_ui := true;
try
- reset_input_buffer stdin top_buffer;
- while true do do_vernac(); loop_flush_all () done
+ reset_input_buffer state.doc stdin top_buffer;
+ (* Be careful to keep this loop tail-recursive *)
+ let rec vernac_loop ~state =
+ let nstate = do_vernac ~time ~state in
+ top_goal_print state.proof nstate.proof;
+ loop_flush_all ();
+ vernac_loop ~state:nstate
+ in vernac_loop ~state
with
- | CErrors.Drop -> ()
+ | CErrors.Drop ->
+ (* Due to using exceptions as a form of control, state here goes
+ out of sync as [do_vernac] will never return. We must thus do
+ this hack until we make `Drop` a toplevel-only command. See
+ bug #6872. *)
+ let state = { state with sid = Stm.get_current_state ~doc:state.doc } in
+ drop_last_doc := Some state;
+ state
| CErrors.Quit -> exit 0
| any ->
- Feedback.msg_error (str"Anomaly: main loop exited with exception: " ++
- str (Printexc.to_string any) ++
- fnl() ++
- str"Please report" ++
- strbrk" at " ++ str Coq_config.wwwbugtracker ++ str ".");
- loop ()
+ top_stderr (str "Anomaly: main loop exited with exception: " ++
+ str (Printexc.to_string any) ++
+ fnl() ++
+ str"Please report" ++
+ strbrk" at " ++ str Coq_config.wwwbugtracker ++ str ".");
+ loop ~time ~state
diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli
index e40353e0..bbb9b138 100644
--- a/toplevel/coqloop.mli
+++ b/toplevel/coqloop.mli
@@ -1,21 +1,24 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
-open Pp
-
(** The Coq toplevel loop. *)
+(** -emacs option: printing includes emacs tags. *)
+val print_emacs : bool ref
+
(** A buffer for the character read from a channel. We store the command
* entered to be able to report errors without pretty-printing. *)
type input_buffer = {
- mutable prompt : unit -> string;
- mutable str : string; (** buffer of already read characters *)
+ mutable prompt : Stm.doc -> string;
+ mutable str : Bytes.t; (** buffer of already read characters *)
mutable len : int; (** number of chars in the buffer *)
mutable bols : int list; (** offsets in str of begining of lines *)
mutable tokens : Pcoq.Gram.coq_parsable; (** stream of tokens *)
@@ -26,16 +29,14 @@ type input_buffer = {
val top_buffer : input_buffer
val set_prompt : (unit -> string) -> unit
-(** Toplevel error explanation, dealing with locations, Drop, Ctrl-D
- May raise only the following exceptions: [Drop] and [End_of_input],
- meaning we get out of the Coq loop. *)
-
-val print_toplevel_error : Exninfo.iexn -> std_ppcmds
+(** Toplevel feedback printer. *)
+val coqloop_feed : Feedback.feedback -> unit
(** Parse and execute one vernac command. *)
-
-val do_vernac : unit -> unit
+val do_vernac : time:bool -> state:Vernac.State.t -> Vernac.State.t
(** Main entry point of Coq: read and execute vernac commands. *)
+val loop : time:bool -> state:Vernac.State.t -> Vernac.State.t
-val loop : unit -> unit
+(** Last document seen after `Drop` *)
+val drop_last_doc : Vernac.State.t option ref
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index d9f8ed88..943b66f6 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -1,19 +1,15 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
open Pp
-open CErrors
-open Util
-open Flags
-open Names
-open Libnames
-open States
-open Coqinit
+open Coqargs
let () = at_exit flush_all
@@ -34,64 +30,31 @@ let print_header () =
Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")");
flush_all ()
-let warning s = with_option Flags.warn Feedback.msg_warning (strbrk s)
+let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s))
-let toploop = ref None
+(* Feedback received in the init stage, this is different as the STM
+ will not be generally be initialized, thus stateid, etc... may be
+ bogus. For now we just print to the console too *)
+let coqtop_init_feed = Coqloop.coqloop_feed
-let color : [`ON | `AUTO | `OFF] ref = ref `AUTO
-let set_color = function
-| "yes" | "on" -> color := `ON
-| "no" | "off" -> color := `OFF
-| "auto" -> color := `AUTO
-| _ -> prerr_endline ("Error: on/off/auto expected after option color"); exit 1
-
-let init_color () =
- let has_color = match !color with
- | `OFF -> false
- | `ON -> true
- | `AUTO ->
- Terminal.has_style Unix.stdout &&
- Terminal.has_style Unix.stderr &&
- (* emacs compilation buffer does not support colors by default,
- its TERM variable is set to "dumb". *)
- try Sys.getenv "TERM" <> "dumb" with Not_found -> false
- in
- if has_color then begin
- let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in
- match colors with
- | None ->
- (** Default colors *)
- Feedback.init_color_output ()
- | Some "" ->
- (** No color output *)
- ()
- | Some s ->
- (** Overwrite all colors *)
- Ppstyle.clear_styles ();
- Ppstyle.parse_config s;
- Feedback.init_color_output ()
- end
-
-let toploop_init = ref begin fun x ->
- let () = init_color () in
- let () = CoqworkmgrApi.(init !Flags.async_proofs_worker_priority) in
- x
- end
-
-let toploop_run = ref (fun () ->
+(* Default toplevel loop *)
+let console_toploop_run opts ~state =
+ (* We initialize the console only if we run the toploop_run *)
+ let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in
if Dumpglob.dump () then begin
- if_verbose warning "Dumpglob cannot be used in interactive mode.";
+ Flags.if_verbose warning "Dumpglob cannot be used in interactive mode.";
Dumpglob.noglob ()
end;
- Coqloop.loop();
+ let _ = Coqloop.loop ~time:opts.time ~state in
(* Initialise and launch the Ocaml toplevel *)
Coqinit.init_ocaml_path();
- Mltop.ocaml_toploop())
+ Mltop.ocaml_toploop();
+ (* We let the feeder in place for users of Drop *)
+ Feedback.del_feeder tl_feed
-let output_context = ref false
+let toploop_run = ref console_toploop_run
let memory_stat = ref false
-
let print_memory_stat () =
begin (* -m|--memory from the command-line *)
if !memory_stat then
@@ -111,151 +74,319 @@ let print_memory_stat () =
let _ = at_exit print_memory_stat
-let impredicative_set = ref Declarations.PredicativeSet
-let set_impredicative_set c = impredicative_set := Declarations.ImpredicativeSet
-let set_type_in_type () =
- let typing_flags = Environ.typing_flags (Global.env ()) in
- Global.set_typing_flags { typing_flags with Declarations.check_universes = false }
-let engage () =
- Global.set_engagement !impredicative_set
-
-let set_batch_mode () = batch_mode := true
-
-let toplevel_default_name = DirPath.make [Id.of_string "Top"]
-let toplevel_name = ref (Some toplevel_default_name)
-let set_toplevel_name dir =
- if DirPath.is_empty dir then error "Need a non empty toplevel module name";
- toplevel_name := Some dir
-let unset_toplevel_name () = toplevel_name := None
-
-let remove_top_ml () = Mltop.remove ()
-
-let warn_deprecated_inputstate =
- CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated"
- (fun () -> strbrk "The inputstate option is deprecated and discouraged.")
-
-let inputstate = ref ""
-let set_inputstate s =
- warn_deprecated_inputstate ();
- inputstate:=s
-let inputstate () =
- if not (String.is_empty !inputstate) then
- let fname = Loadpath.locate_file (CUnix.make_suffix !inputstate ".coq") in
- intern_state fname
-
-let warn_deprecated_outputstate =
- CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated"
- (fun () ->
- strbrk "The outputstate option is deprecated and discouraged.")
-
-let outputstate = ref ""
-let set_outputstate s =
- warn_deprecated_outputstate ();
- outputstate:=s
-let outputstate () =
- if not (String.is_empty !outputstate) then
- let fname = CUnix.make_suffix !outputstate ".coq" in
- extern_state fname
-
-let set_include d p implicit =
- let p = dirpath_of_string p in
- push_include d p implicit
-
-let load_vernacular_list = ref ([] : (string * bool) list)
-let add_load_vernacular verb s =
- load_vernacular_list := ((CUnix.make_suffix s ".v"),verb) :: !load_vernacular_list
-let load_vernacular () =
- List.iter
- (fun (s,b) ->
- let s = Loadpath.locate_file s in
- if !Flags.beautify then
- with_option beautify_file (Vernac.load_vernac b) s
- else
- Vernac.load_vernac b s)
- (List.rev !load_vernacular_list)
-
-let load_vernacular_obj = ref ([] : string list)
-let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj
-let load_vernac_obj () =
- let map dir = Qualid (Loc.ghost, qualid_of_string dir) in
- Vernacentries.vernac_require None None (List.rev_map map !load_vernacular_obj)
-
-let require_prelude () =
- let vo = Envars.coqlib () / "theories/Init/Prelude.vo" in
- let vio = Envars.coqlib () / "theories/Init/Prelude.vio" in
- let m =
- if Sys.file_exists vo then vo else
- if Sys.file_exists vio then vio else vo in
- Library.require_library_from_dirpath [Coqlib.prelude_module,m] (Some true)
-
-let require_list = ref ([] : string list)
-let add_require s = require_list := s :: !require_list
-let require () =
- let () = if !load_init then silently require_prelude () in
- let map dir = Qualid (Loc.ghost, qualid_of_string dir) in
- Vernacentries.vernac_require None (Some false) (List.rev_map map !require_list)
-
-let add_compat_require v =
- match v with
- | Flags.V8_4 -> add_require "Coq.Compat.Coq84"
- | Flags.V8_5 -> add_require "Coq.Compat.Coq85"
- | _ -> ()
-
-let compile_list = ref ([] : (bool * string) list)
-
-let glob_opt = ref false
-
-let add_compile verbose s =
- set_batch_mode ();
- Flags.make_silent true;
- if not !glob_opt then Dumpglob.dump_to_dotglob ();
- (** make the file name explicit; needed not to break up Coq loadpath stuff. *)
- let s =
- let open Filename in
- if is_implicit s
- then concat current_dir_name s
- else s
+(******************************************************************************)
+(* Input/Output State *)
+(******************************************************************************)
+let inputstate opts =
+ Option.iter (fun istate_file ->
+ let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in
+ States.intern_state fname) opts.inputstate
+
+let outputstate opts =
+ Option.iter (fun ostate_file ->
+ let fname = CUnix.make_suffix ostate_file ".coq" in
+ States.extern_state fname) opts.outputstate
+
+(******************************************************************************)
+(* Interactive Load File Simulation *)
+(******************************************************************************)
+let load_vernacular opts ~state =
+ List.fold_left
+ (fun state (f_in, echo) ->
+ let s = Loadpath.locate_file f_in in
+ (* Should make the beautify logic clearer *)
+ let load_vernac f = Vernac.load_vernac ~time:opts.time ~echo ~interactive:false ~check:true ~state f in
+ if !Flags.beautify
+ then Flags.with_option Flags.beautify_file load_vernac f_in
+ else load_vernac s
+ ) state (List.rev opts.load_vernacular_list)
+
+let load_init_vernaculars opts ~state =
+ let state = if opts.load_rcfile then
+ Coqinit.load_rcfile ~rcfile:opts.rcfile ~time:opts.time ~state
+ else begin
+ Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading.");
+ state
+ end in
+
+ load_vernacular opts ~state
+
+(******************************************************************************)
+(* Startup LoadPath and Modules *)
+(******************************************************************************)
+(* prelude_data == From Coq Require Export Prelude. *)
+let prelude_data = "Prelude", Some "Coq", Some true
+
+let require_libs opts =
+ if opts.load_init then prelude_data :: opts.vo_requires else opts.vo_requires
+
+let cmdline_load_path opts =
+ let open Mltop in
+ (* loadpaths given by options -Q and -R *)
+ List.map
+ (fun (unix_path, coq_path, implicit) ->
+ { recursive = true;
+ path_spec = VoPath { unix_path; coq_path; has_ml = Mltop.AddNoML; implicit } })
+ (List.rev opts.vo_includes) @
+
+ (* additional ml directories, given with option -I *)
+ List.map (fun s -> {recursive = false; path_spec = MlPath s}) (List.rev opts.ml_includes)
+
+let build_load_path opts =
+ Coqinit.libs_init_load_path ~load_init:opts.load_init @
+ cmdline_load_path opts
+
+(******************************************************************************)
+(* Fatal Errors *)
+(******************************************************************************)
+
+(** Prints info which is either an error or an anomaly and then exits
+ with the appropriate error code *)
+let fatal_error msg =
+ Topfmt.std_logger Feedback.Error msg;
+ flush_all ();
+ exit 1
+
+let fatal_error_exn ?extra exn =
+ Topfmt.print_err_exn ?extra exn;
+ flush_all ();
+ let exit_code =
+ if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1
in
- compile_list := (verbose,s) :: !compile_list
+ exit exit_code
+
+(******************************************************************************)
+(* File Compilation *)
+(******************************************************************************)
+let warn_file_no_extension =
+ CWarnings.create ~name:"file-no-extension" ~category:"filesystem"
+ (fun (f,ext) ->
+ str "File \"" ++ str f ++
+ strbrk "\" has been implicitly expanded to \"" ++
+ str f ++ str ext ++ str "\"")
+
+let ensure_ext ext f =
+ if Filename.check_suffix f ext then f
+ else begin
+ warn_file_no_extension (f,ext);
+ f ^ ext
+ end
-let compile_file (v,f) =
+let chop_extension f =
+ try Filename.chop_extension f with _ -> f
+
+let ensure_bname src tgt =
+ let src, tgt = Filename.basename src, Filename.basename tgt in
+ let src, tgt = chop_extension src, chop_extension tgt in
+ if src <> tgt then
+ fatal_error (str "Source and target file names must coincide, directories can differ" ++ fnl () ++
+ str "Source: " ++ str src ++ fnl () ++
+ str "Target: " ++ str tgt)
+
+let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt
+
+let ensure_v v = ensure ".v" v v
+let ensure_vo v vo = ensure ".vo" v vo
+let ensure_vio v vio = ensure ".vio" v vio
+
+let ensure_exists f =
+ if not (Sys.file_exists f) then
+ fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f))
+
+(* Compile a vernac file *)
+let compile opts ~echo ~f_in ~f_out =
+ let open Vernac.State in
+ let check_pending_proofs () =
+ let pfs = Proof_global.get_all_proof_names () in
+ if not (CList.is_empty pfs) then
+ fatal_error (str "There are pending proofs: "
+ ++ (pfs
+ |> List.rev
+ |> prlist_with_sep pr_comma Names.Id.print)
+ ++ str ".")
+ in
+ let iload_path = build_load_path opts in
+ let require_libs = require_libs opts in
+ let stm_options = opts.stm_flags in
+ match opts.compilation_mode with
+ | BuildVo ->
+ Flags.record_aux_file := true;
+ let long_f_dot_v = ensure_v f_in in
+ ensure_exists long_f_dot_v;
+ let long_f_dot_vo =
+ match f_out with
+ | None -> long_f_dot_v ^ "o"
+ | Some f -> ensure_vo long_f_dot_v f in
+
+ let doc, sid = Stm.(new_doc
+ { doc_type = VoDoc long_f_dot_vo;
+ iload_path; require_libs; stm_options;
+ }) in
+
+ let state = { doc; sid; proof = None } in
+ let state = load_init_vernaculars opts ~state in
+ let ldir = Stm.get_ldir ~doc:state.doc in
+ Aux_file.(start_aux_file
+ ~aux_file:(aux_file_name_for long_f_dot_vo)
+ ~v_file:long_f_dot_v);
+ Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo;
+ Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n");
+ let wall_clock1 = Unix.gettimeofday () in
+ let state = Vernac.load_vernac ~time:opts.time ~echo ~check:true ~interactive:false ~state long_f_dot_v in
+ let _doc = Stm.join ~doc:state.doc in
+ let wall_clock2 = Unix.gettimeofday () in
+ check_pending_proofs ();
+ Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ());
+ Aux_file.record_in_aux_at "vo_compile_time"
+ (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1));
+ Aux_file.stop_aux_file ();
+ Dumpglob.end_dump_glob ()
+
+ | BuildVio ->
+ Flags.record_aux_file := false;
+ Dumpglob.noglob ();
+
+ let long_f_dot_v = ensure_v f_in in
+ ensure_exists long_f_dot_v;
+
+ let long_f_dot_vio =
+ match f_out with
+ | None -> long_f_dot_v ^ "io"
+ | Some f -> ensure_vio long_f_dot_v f in
+
+ (* We need to disable error resiliency, otherwise some errors
+ will be ignored in batch mode. c.f. #6707
+
+ This is not necessary in the vo case as it fully checks the
+ document anyways. *)
+ let stm_options = let open Stm.AsyncOpts in
+ { stm_options with
+ async_proofs_cmd_error_resilience = false;
+ async_proofs_tac_error_resilience = `None;
+ } in
+
+ let doc, sid = Stm.(new_doc
+ { doc_type = VioDoc long_f_dot_vio;
+ iload_path; require_libs; stm_options;
+ }) in
+
+ let state = { doc; sid; proof = None } in
+ let state = load_init_vernaculars opts ~state in
+ let ldir = Stm.get_ldir ~doc:state.doc in
+ let state = Vernac.load_vernac ~time:opts.time ~echo ~check:false ~interactive:false ~state long_f_dot_v in
+ let doc = Stm.finish ~doc:state.doc in
+ check_pending_proofs ();
+ let _doc = Stm.snapshot_vio ~doc ldir long_f_dot_vio in
+ Stm.reset_task_queue ()
+
+ | Vio2Vo ->
+ let open Filename in
+ Flags.record_aux_file := false;
+ Dumpglob.noglob ();
+ let f = if check_suffix f_in ".vio" then chop_extension f_in else f_in in
+ let lfdv, sum, lib, univs, disch, tasks, proofs = Library.load_library_todo f in
+ let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in
+ Library.save_library_raw lfdv sum lib univs proofs
+
+let compile opts ~echo ~f_in ~f_out =
+ ignore(CoqworkmgrApi.get 1);
+ compile opts ~echo ~f_in ~f_out;
+ CoqworkmgrApi.giveback 1
+
+let compile_file opts (f_in, echo) =
+ let f_out = opts.compilation_output_name in
if !Flags.beautify then
- with_option beautify_file (Vernac.compile v) f
+ Flags.with_option Flags.beautify_file
+ (fun f_in -> compile opts ~echo ~f_in ~f_out) f_in
else
- Vernac.compile v f
+ compile opts ~echo ~f_in ~f_out
-let compile_files () =
- if !compile_list == [] then ()
- else
- let init_state = States.freeze ~marshallable:`No in
- Feedback.(add_feeder debug_feeder);
- List.iter (fun vf ->
- States.unfreeze init_state;
- compile_file vf)
- (List.rev !compile_list)
+let compile_files opts =
+ let compile_list = List.rev opts.compile_list in
+ List.iter (compile_file opts) compile_list
-(** Options for proof general *)
-
-let set_emacs () =
- if not (Option.is_empty !toploop) then
- error "Flag -emacs is incompatible with a custom toplevel loop";
- Flags.print_emacs := true;
- Feedback.(set_logger emacs_logger);
- Vernacentries.qed_display_script := false;
- color := `OFF
-
-(** Options for CoqIDE *)
+(******************************************************************************)
+(* VIO Dispatching *)
+(******************************************************************************)
+let check_vio_tasks opts =
+ let rc =
+ List.fold_left (fun acc t -> Vio_checking.check_vio t && acc)
+ true (List.rev opts.vio_tasks) in
+ if not rc then fatal_error Pp.(str "VIO Task Check failed")
-let set_ideslave () =
- if !Flags.print_emacs then error "Flags -ideslave and -emacs are incompatible";
- toploop := Some "coqidetop";
- Flags.ide_slave := true
+(* vio files *)
+let schedule_vio opts =
+ if opts.vio_checking then
+ Vio_checking.schedule_vio_checking opts.vio_files_j opts.vio_files
+ else
+ Vio_checking.schedule_vio_compilation opts.vio_files_j opts.vio_files
+
+let do_vio opts =
+ (* We must initialize the loadpath here as the vio scheduling
+ process happens outside of the STM *)
+ if opts.vio_files <> [] || opts.vio_tasks <> [] then
+ let iload_path = build_load_path opts in
+ List.iter Mltop.add_coq_path iload_path;
+
+ (* Vio compile pass *)
+ if opts.vio_files <> [] then schedule_vio opts;
+ (* Vio task pass *)
+ if opts.vio_tasks <> [] then check_vio_tasks opts
+
+
+(******************************************************************************)
+(* Color Options *)
+(******************************************************************************)
+let init_color color_mode =
+ let has_color = match color_mode with
+ | `OFF -> false
+ | `ON -> true
+ | `AUTO ->
+ Terminal.has_style Unix.stdout &&
+ Terminal.has_style Unix.stderr &&
+ (* emacs compilation buffer does not support colors by default,
+ its TERM variable is set to "dumb". *)
+ try Sys.getenv "TERM" <> "dumb" with Not_found -> false
+ in
+ if has_color then begin
+ let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in
+ match colors with
+ | None ->
+ (** Default colors *)
+ Topfmt.default_styles ();
+ Topfmt.init_terminal_output ~color:true
+ | Some "" ->
+ (** No color output *)
+ Topfmt.init_terminal_output ~color:false
+ | Some s ->
+ (** Overwrite all colors *)
+ Topfmt.parse_color_config s;
+ Topfmt.init_terminal_output ~color:true
+ end
+ else
+ Topfmt.init_terminal_output ~color:false
-(** Options for slaves *)
+let toploop_init = ref begin fun opts x ->
+ let () = init_color opts.color in
+ let () = CoqworkmgrApi.init !WorkerLoop.async_proofs_worker_priority in
+ x
+ end
-let set_toploop name =
- if !Flags.print_emacs then error "Flags -toploop and -emacs are incompatible";
- toploop := Some name
+let print_style_tags opts =
+ let () = init_color opts.color in
+ let tags = Topfmt.dump_tags () in
+ let iter (t, st) =
+ let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in
+ print_string opt
+ in
+ let make (t, st) =
+ let tags = List.map string_of_int (Terminal.repr st) in
+ (t ^ "=" ^ String.concat ";" tags)
+ in
+ let repr = List.map make tags in
+ let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in
+ let () = List.iter iter tags in
+ flush_all ()
(** GC tweaking *)
@@ -282,389 +413,112 @@ let init_gc () =
Gc.minor_heap_size = 33554432; (** 4M *)
Gc.space_overhead = 120}
-(*s Parsing of the command line.
- We no longer use [Arg.parse], in order to use share [Usage.print_usage]
- between coqtop and coqc. *)
-
-let usage () =
- Envars.set_coqlib CErrors.error;
- init_load_path ();
- if !batch_mode then Usage.print_usage_coqc ()
- else begin
- Mltop.load_ml_objects_raw_rex
- (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$"));
- Usage.print_usage_coqtop ()
- end
-
-let print_style_tags () =
- let () = init_color () in
- let tags = Ppstyle.dump () in
- let iter (t, st) =
- let st = match st with Some st -> st | None -> Terminal.make () in
- let opt =
- Terminal.eval st ^
- String.concat "." (Ppstyle.repr t) ^
- Terminal.reset ^ "\n"
- in
- print_string opt
- in
- let make (t, st) = match st with
- | None -> None
- | Some st ->
- let tags = List.map string_of_int (Terminal.repr st) in
- let t = String.concat "." (Ppstyle.repr t) in
- Some (t ^ "=" ^ String.concat ";" tags)
- in
- let repr = List.map_filter make tags in
- let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in
- let () = List.iter iter tags in
- flush_all ()
-
-let error_missing_arg s =
- prerr_endline ("Error: extra argument expected after option "^s);
- prerr_endline "See -help for the syntax of supported options";
- exit 1
-
-let filter_opts = ref false
-let exitcode () = if !filter_opts then 2 else 0
-
-let print_where = ref false
-let print_config = ref false
-let print_tags = ref false
-
-let get_priority opt s =
- try Flags.priority_of_string s
- with Invalid_argument _ ->
- prerr_endline ("Error: low/high expected after "^opt); exit 1
-
-let get_async_proofs_mode opt = function
- | "no" | "off" -> Flags.APoff
- | "yes" | "on" -> Flags.APon
- | "lazy" -> Flags.APonLazy
- | _ -> prerr_endline ("Error: on/off/lazy expected after "^opt); exit 1
-
-let get_cache opt = function
- | "force" -> Some Flags.Force
- | _ -> prerr_endline ("Error: force expected after "^opt); exit 1
-
-
-let set_worker_id opt s =
- assert (s <> "master");
- Flags.async_proofs_worker_id := s
-
-let get_bool opt = function
- | "yes" | "on" -> true
- | "no" | "off" -> false
- | _ -> prerr_endline ("Error: yes/no expected after option "^opt); exit 1
-
-let get_int opt n =
- try int_of_string n
- with Failure _ ->
- prerr_endline ("Error: integer expected after option "^opt); exit 1
-
-let get_float opt n =
- try float_of_string n
- with Failure _ ->
- prerr_endline ("Error: float expected after option "^opt); exit 1
-
-let get_host_port opt s =
- match CString.split ':' s with
- | [host; portr; portw] ->
- Some (Spawned.Socket(host, int_of_string portr, int_of_string portw))
- | ["stdfds"] -> Some Spawned.AnonPipe
- | _ ->
- prerr_endline ("Error: host:portr:portw or stdfds expected after option "^opt);
- exit 1
-
-let get_error_resilience opt = function
- | "on" | "all" | "yes" -> `All
- | "off" | "no" -> `None
- | s -> `Only (String.split ',' s)
-
-let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s)
-
-let vio_tasks = ref []
-
-let add_vio_task f =
- set_batch_mode ();
- Flags.make_silent true;
- vio_tasks := f :: !vio_tasks
-
-let check_vio_tasks () =
- let rc =
- List.fold_left (fun acc t -> Vio_checking.check_vio t && acc)
- true (List.rev !vio_tasks) in
- if not rc then exit 1
-
-let vio_files = ref []
-let vio_files_j = ref 0
-let vio_checking = ref false
-let add_vio_file f =
- set_batch_mode ();
- Flags.make_silent true;
- vio_files := f :: !vio_files
-
-let set_vio_checking_j opt j =
- try vio_files_j := int_of_string j
- with Failure _ ->
- prerr_endline ("The first argument of " ^ opt ^ " must the number");
- prerr_endline "of concurrent workers to be used (a positive integer).";
- prerr_endline "Makefiles generated by coq_makefile should be called";
- prerr_endline "setting the J variable like in 'make vio2vo J=3'";
- exit 1
-
-let is_not_dash_option = function
- | Some f when String.length f > 0 && f.[0] <> '-' -> true
- | _ -> false
-
-let schedule_vio_checking () =
- if !vio_files <> [] && !vio_checking then
- Vio_checking.schedule_vio_checking !vio_files_j !vio_files
-let schedule_vio_compilation () =
- if !vio_files <> [] && not !vio_checking then
- Vio_checking.schedule_vio_compilation !vio_files_j !vio_files
-
-let get_native_name s =
- (* We ignore even critical errors because this mode has to be super silent *)
- try
- String.concat "/" [Filename.dirname s;
- Nativelib.output_dir; Library.native_name_from_filename s]
- with _ -> ""
-
-let parse_args arglist =
- let args = ref arglist in
- let extras = ref [] in
- let rec parse () = match !args with
- | [] -> List.rev !extras
- | opt :: rem ->
- args := rem;
- let next () = match !args with
- | x::rem -> args := rem; x
- | [] -> error_missing_arg opt
- in
- let peek_next () = match !args with
- | x::_ -> Some x
- | [] -> None
- in
- begin match opt with
-
- (* Complex options with many args *)
- |"-I"|"-include" ->
- begin match rem with
- | d :: rem -> push_ml_include d; args := rem
- | [] -> error_missing_arg opt
- end
- |"-Q" ->
- begin match rem with
- | d :: p :: rem -> set_include d p false; args := rem
- | _ -> error_missing_arg opt
- end
- |"-R" ->
- begin match rem with
- | d :: p :: rem -> set_include d p true; args := rem
- | _ -> error_missing_arg opt
- end
-
- (* Options with two arg *)
- |"-check-vio-tasks" ->
- let tno = get_task_list (next ()) in
- let tfile = next () in
- add_vio_task (tno,tfile)
- |"-schedule-vio-checking" ->
- vio_checking := true;
- set_vio_checking_j opt (next ());
- add_vio_file (next ());
- while is_not_dash_option (peek_next ()) do add_vio_file (next ()); done
- |"-schedule-vio2vo" ->
- set_vio_checking_j opt (next ());
- add_vio_file (next ());
- while is_not_dash_option (peek_next ()) do add_vio_file (next ()); done
-
- (* Options with one arg *)
- |"-coqlib" -> Flags.coqlib_spec:=true; Flags.coqlib:=(next ())
- |"-async-proofs" ->
- Flags.async_proofs_mode := get_async_proofs_mode opt (next())
- |"-async-proofs-j" ->
- Flags.async_proofs_n_workers := (get_int opt (next ()))
- |"-async-proofs-cache" ->
- Flags.async_proofs_cache := get_cache opt (next ())
- |"-async-proofs-tac-j" ->
- Flags.async_proofs_n_tacworkers := (get_int opt (next ()))
- |"-async-proofs-worker-priority" ->
- Flags.async_proofs_worker_priority := get_priority opt (next ())
- |"-async-proofs-private-flags" ->
- Flags.async_proofs_private_flags := Some (next ());
- |"-async-proofs-tactic-error-resilience" ->
- Flags.async_proofs_tac_error_resilience := get_error_resilience opt (next ())
- |"-async-proofs-command-error-resilience" ->
- Flags.async_proofs_cmd_error_resilience := get_bool opt (next ())
- |"-async-proofs-delegation-threshold" ->
- Flags.async_proofs_delegation_threshold:= get_float opt (next ())
- |"-worker-id" -> set_worker_id opt (next ())
- |"-compat" -> let v = get_compat_version (next ()) in Flags.compat_version := v; add_compat_require v
- |"-compile" -> add_compile false (next ())
- |"-compile-verbose" -> add_compile true (next ())
- |"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true
- |"-feedback-glob" -> Dumpglob.feedback_glob ()
- |"-exclude-dir" -> System.exclude_directory (next ())
- |"-init-file" -> set_rcfile (next ())
- |"-inputstate"|"-is" -> set_inputstate (next ())
- |"-load-ml-object" -> Mltop.dir_ml_load (next ())
- |"-load-ml-source" -> Mltop.dir_ml_use (next ())
- |"-load-vernac-object" -> add_vernac_obj (next ())
- |"-load-vernac-source"|"-l" -> add_load_vernacular false (next ())
- |"-load-vernac-source-verbose"|"-lv" -> add_load_vernacular true (next ())
- |"-outputstate" -> set_outputstate (next ())
- |"-print-mod-uid" -> let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0
- |"-profile-ltac-cutoff" -> Flags.profile_ltac := true; Flags.profile_ltac_cutoff := get_float opt (next ())
- |"-require" -> add_require (next ())
- |"-top" -> set_toplevel_name (dirpath_of_string (next ()))
- |"-with-geoproof" -> Coq_config.with_geoproof := get_bool opt (next ())
- |"-main-channel" -> Spawned.main_channel := get_host_port opt (next())
- |"-control-channel" -> Spawned.control_channel := get_host_port opt (next())
- |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Vio2Vo
- |"-toploop" -> set_toploop (next ())
- |"-w" | "-W" -> CWarnings.set_flags (CWarnings.normalize_flags_string (next ()))
- |"-o" -> Flags.compilation_output_name := Some (next())
-
- (* Options with zero arg *)
- |"-async-queries-always-delegate"
- |"-async-proofs-always-delegate"
- |"-async-proofs-full" ->
- Flags.async_proofs_full := true;
- |"-async-proofs-never-reopen-branch" ->
- Flags.async_proofs_never_reopen_branch := true;
- |"-batch" -> set_batch_mode ()
- |"-test-mode" -> test_mode := true
- |"-beautify" -> beautify := true
- |"-boot" -> boot := true; no_load_rc ()
- |"-bt" -> Backtrace.record_backtrace true
- |"-color" -> set_color (next ())
- |"-config"|"--config" -> print_config := true
- |"-debug" -> set_debug ()
- |"-emacs" -> set_emacs ()
- |"-filteropts" -> filter_opts := true
- |"-h"|"-H"|"-?"|"-help"|"--help" -> usage ()
- |"-ideslave" -> set_ideslave ()
- |"-impredicative-set" -> set_impredicative_set ()
- |"-indices-matter" -> Indtypes.enforce_indices_matter ()
- |"-just-parsing" -> warning "-just-parsing option has been removed in 8.6"
- |"-m"|"--memory" -> memory_stat := true
- |"-noinit"|"-nois" -> load_init := false
- |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true
- |"-native-compiler" ->
- if Coq_config.no_native_compiler then
- warning "Native compilation was disabled at configure time."
- else native_compiler := true
- |"-notop" -> unset_toplevel_name ()
- |"-output-context" -> output_context := true
- |"-profile-ltac" -> Flags.profile_ltac := true
- |"-q" -> no_load_rc ()
- |"-quiet"|"-silent" -> Flags.make_silent true; Flags.make_warn false
- |"-quick" -> Flags.compilation_mode := BuildVio
- |"-list-tags" -> print_tags := true
- |"-time" -> Flags.time := true
- |"-type-in-type" -> set_type_in_type ()
- |"-unicode" -> add_require "Utf8_core"
- |"-v"|"--version" -> Usage.version (exitcode ())
- |"--print-version" -> Usage.machine_readable_version (exitcode ())
- |"-where" -> print_where := true
- |"-xml" -> Flags.xml_export := true
-
- (* Deprecated options *)
- |"-byte" -> warning "option -byte deprecated, call with .byte suffix"
- |"-opt" -> warning "option -opt deprecated, call with .opt suffix"
- |"-full" -> warning "option -full deprecated"
- |"-notactics" -> warning "Obsolete option \"-notactics\"."; remove_top_ml ()
- |"-emacs-U" ->
- warning "Obsolete option \"-emacs-U\", use -emacs instead."; set_emacs ()
- |"-v7" -> error "This version of Coq does not support v7 syntax"
- |"-v8" -> warning "Obsolete option \"-v8\"."
- |"-lazy-load-proofs" -> warning "Obsolete option \"-lazy-load-proofs\"."
- |"-dont-load-proofs" -> warning "Obsolete option \"-dont-load-proofs\"."
- |"-force-load-proofs" -> warning "Obsolete option \"-force-load-proofs\"."
- |"-unsafe" -> warning "Obsolete option \"-unsafe\"."; ignore (next ())
- |"-quality" -> warning "Obsolete option \"-quality\"."
-
- (* Unknown option *)
- | s -> extras := s :: !extras
- end;
- parse ()
- in
- try
- parse ()
- with
- | UserError(_, s) as e ->
- if is_empty s then exit 1
- else fatal_error (CErrors.print e) false
- | any -> fatal_error (CErrors.print any) (CErrors.is_anomaly any)
-
+(** Main init routine *)
let init_toplevel arglist =
+ (* Coq's init process, phase 1:
+ OCaml parameters, basic structures, and IO
+ *)
+ CProfile.init_profile ();
init_gc ();
Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
+ let init_feeder = Feedback.add_feeder coqtop_init_feed in
Lib.init();
- (* Default Proofb Mode starts with an alternative default. *)
- Goptions.set_string_option_value ["Default";"Proof";"Mode"] "Classic";
- begin
+
+ (* Coq's init process, phase 2:
+ Basic Coq environment, load-path, plugins.
+ *)
+ let res = begin
try
- let extras = parse_args arglist in
+ let opts,extras = parse_args arglist in
+ memory_stat := opts.memory_stat;
+
(* If we have been spawned by the Spawn module, this has to be done
* early since the master waits us to connect back *)
Spawned.init_channels ();
- Envars.set_coqlib CErrors.error;
- if !print_where then (print_endline(Envars.coqlib ()); exit(exitcode ()));
- if !print_config then (Usage.print_config (); exit (exitcode ()));
- if !print_tags then (print_style_tags (); exit (exitcode ()));
- if !filter_opts then (print_string (String.concat "\n" extras); exit 0);
- init_load_path ();
- Option.iter Mltop.load_ml_object_raw !toploop;
- let extras = !toploop_init extras in
- if not (List.is_empty extras) then begin
+ Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg));
+ if opts.print_where then (print_endline(Envars.coqlib ()); exit(exitcode opts));
+ if opts.print_config then (Envars.print_config stdout Coq_config.all_src_dirs; exit (exitcode opts));
+ if opts.print_tags then (print_style_tags opts; exit (exitcode opts));
+ if opts.filter_opts then (print_string (String.concat "\n" extras); exit 0);
+ let top_lp = Coqinit.toplevel_init_load_path () in
+ List.iter Mltop.add_coq_path top_lp;
+ Option.iter Mltop.load_ml_object_raw opts.toploop;
+ let extras = !toploop_init opts extras in
+ if not (CList.is_empty extras) then begin
prerr_endline ("Don't know what to do with "^String.concat " " extras);
prerr_endline "See -help for the list of supported options";
exit 1
end;
- if_verbose print_header ();
- inputstate ();
+ Flags.if_verbose print_header ();
Mltop.init_known_plugins ();
- engage ();
- if (not !batch_mode || List.is_empty !compile_list)
- && Global.env_is_initial ()
- then Option.iter Declaremods.start_library !toplevel_name;
- init_library_roots ();
- load_vernac_obj ();
- require ();
- Stm.init ();
- load_rcfile();
- load_vernacular ();
- compile_files ();
- schedule_vio_checking ();
- schedule_vio_compilation ();
- check_vio_tasks ();
- outputstate ()
+ Global.set_engagement opts.impredicative_set;
+
+ (* Allow the user to load an arbitrary state here *)
+ inputstate opts;
+
+ (* This state will be shared by all the documents *)
+ Stm.init_core ();
+
+ (* Coq init process, phase 3: Stm initialization, backtracking state.
+
+ It is essential that the module system is in a consistent
+ state before we take the first snapshot. This was not
+ guaranteed in the past, but now is thanks to the STM API.
+
+ We split the codepath here depending whether coqtop is called
+ in interactive mode or not. *)
+
+ (* The condition for starting the interactive mode is a bit
+ convoluted, we should really refactor batch/compilation_mode
+ more. *)
+ if (not opts.batch_mode
+ || CList.(is_empty opts.compile_list && is_empty opts.vio_files && is_empty opts.vio_tasks))
+ (* Interactive *)
+ then begin
+ let iload_path = build_load_path opts in
+ let require_libs = require_libs opts in
+ let stm_options = opts.stm_flags in
+ try
+ let open Vernac.State in
+ let doc, sid =
+ Stm.(new_doc
+ { doc_type = Interactive opts.toplevel_name;
+ iload_path; require_libs; stm_options;
+ }) in
+ let state = { doc; sid; proof = None } in
+ Some (load_init_vernaculars opts ~state), opts
+ with any -> flush_all(); fatal_error_exn any
+ (* Non interactive: we perform a sequence of compilation steps *)
+ end else begin
+ try
+ compile_files opts;
+ (* Careful this will modify the load-path and state so after
+ this point some stuff may not be safe anymore. *)
+ do_vio opts;
+ (* Allow the user to output an arbitrary state *)
+ outputstate opts;
+ None, opts
+ with any -> flush_all(); fatal_error_exn any
+ end;
with any ->
- let any = CErrors.push any in
flush_all();
- let msg =
- if !batch_mode then mt ()
- else str "Error during initialization:" ++ fnl ()
- in
- let is_anomaly e = CErrors.is_anomaly e || not (CErrors.handled e) in
- fatal_error (msg ++ Coqloop.print_toplevel_error any) (is_anomaly (fst any))
- end;
- if !batch_mode then begin
- flush_all();
- if !output_context then
- Feedback.msg_notice (with_option raw_print Prettyp.print_full_pure_context () ++ fnl ());
- Profile.print_profile ();
- exit 0
- end
+ let extra = Some (str "Error during initialization: ") in
+ fatal_error_exn ?extra any
+ end in
+ Feedback.del_feeder init_feeder;
+ res
let start () =
- let () = init_toplevel (List.tl (Array.to_list Sys.argv)) in
- (* In batch mode, Coqtop has already exited at this point. In interactive one,
- dump glob is nothing but garbage ... *)
- !toploop_run ();
- exit 1
-
-(* [Coqtop.start] will be called by the code produced by coqmktop *)
+ match init_toplevel (List.tl (Array.to_list Sys.argv)) with
+ (* Batch mode *)
+ | Some state, opts when not opts.batch_mode ->
+ !toploop_run opts ~state;
+ exit 1
+ | _ , opts ->
+ flush_all();
+ if opts.output_context then begin
+ let sigma, env = Pfedit.get_current_context () in
+ Feedback.msg_notice (Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ())
+ end;
+ CProfile.print_profile ();
+ exit 0
diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli
index c9d1ba45..056279bb 100644
--- a/toplevel/coqtop.mli
+++ b/toplevel/coqtop.mli
@@ -1,9 +1,11 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
(** The Coq main module. The following function [start] will parse the
@@ -11,12 +13,10 @@
state, load the files given on the command line, load the resource file,
produce the output state if any, and finally will launch [Coqloop.loop]. *)
-val init_toplevel : string list -> unit
+val init_toplevel : string list -> Vernac.State.t option * Coqargs.coq_cmdopts
val start : unit -> unit
-
(* For other toploops *)
-val toploop_init : (string list -> string list) ref
-val toploop_run : (unit -> unit) ref
-
+val toploop_init : (Coqargs.coq_cmdopts -> string list -> string list) ref
+val toploop_run : (Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit) ref
diff --git a/toplevel/coqtop_byte_bin.ml b/toplevel/coqtop_byte_bin.ml
new file mode 100644
index 00000000..0b65cebb
--- /dev/null
+++ b/toplevel/coqtop_byte_bin.ml
@@ -0,0 +1,34 @@
+(************************************************************************)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
+(************************************************************************)
+
+let drop_setup () =
+ begin try
+ (* Enable rectypes in the toplevel if it has the directive #rectypes *)
+ begin match Hashtbl.find Toploop.directive_table "rectypes" with
+ | Toploop.Directive_none f -> f ()
+ | _ -> ()
+ end
+ with
+ | Not_found -> ()
+ end;
+ let ppf = Format.std_formatter in
+ Mltop.(set_top
+ { load_obj = (fun f -> if not (Topdirs.load_file ppf f)
+ then CErrors.user_err Pp.(str ("Could not load plugin "^f))
+ );
+ use_file = Topdirs.dir_use ppf;
+ add_dir = Topdirs.dir_directory;
+ ml_loop = (fun () -> Toploop.loop ppf);
+ })
+
+(* Main coqtop initialization *)
+let _ =
+ drop_setup ();
+ Coqtop.start()
diff --git a/toplevel/coqtop_opt_bin.ml b/toplevel/coqtop_opt_bin.ml
new file mode 100644
index 00000000..ea4c0ea5
--- /dev/null
+++ b/toplevel/coqtop_opt_bin.ml
@@ -0,0 +1,16 @@
+(************************************************************************)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
+(************************************************************************)
+
+let drop_setup () = Mltop.remove ()
+
+(* Main coqtop initialization *)
+let _ =
+ drop_setup ();
+ Coqtop.start()
diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml
deleted file mode 100644
index e24d5e74..00000000
--- a/toplevel/discharge.ml
+++ /dev/null
@@ -1,120 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open 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 (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,abs_ctx) modlist mib =
- let nparams = mib.mind_nparams in
- let subst, univs =
- if mib.mind_polymorphic then
- let inst = Univ.UContext.instance mib.mind_universes in
- let cstrs = Univ.UContext.constraints mib.mind_universes in
- inst, Univ.UContext.make (inst, Univ.subst_instance_constraints inst cstrs)
- else Univ.Instance.empty, mib.mind_universes
- in
- let inds =
- Array.map_to_list
- (fun mip ->
- let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in
- let arity = expmod_constr modlist ty in
- let arity = Vars.subst_instance_constr subst arity in
- let lc = Array.map
- (fun c -> Vars.subst_instance_constr subst (expmod_constr modlist c))
- 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 (expmod_constr modlist) sechyps in
- let (params',inds') = abstract_inductive sechyps' nparams inds in
- let abs_ctx = Univ.instantiate_univ_context abs_ctx in
- let univs = Univ.UContext.union abs_ctx univs 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_polymorphic = mib.mind_polymorphic;
- mind_entry_private = mib.mind_private;
- mind_entry_universes = univs;
- }
diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli
deleted file mode 100644
index 18d1b677..00000000
--- a/toplevel/discharge.mli
+++ /dev/null
@@ -1,14 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Declarations
-open Entries
-open Opaqueproof
-
-val process_inductive :
- Context.Named.t Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry
diff --git a/toplevel/doc.tex b/toplevel/doc.tex
deleted file mode 100644
index f2550fda..00000000
--- a/toplevel/doc.tex
+++ /dev/null
@@ -1,10 +0,0 @@
-
-\newpage
-\section*{The Coq toplevel}
-
-\ocwsection \label{toplevel}
-This chapter describes the highest modules of the \Coq\ system.
-They are organized as follows:
-
-\bigskip
-\begin{center}\epsfig{file=toplevel.dep.ps,width=\linewidth}\end{center}
diff --git a/toplevel/explainErr.ml b/toplevel/explainErr.ml
deleted file mode 100644
index 17897460..00000000
--- a/toplevel/explainErr.ml
+++ /dev/null
@@ -1,129 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open CErrors
-open Indtypes
-open Type_errors
-open Pretype_errors
-open Indrec
-
-let guill s = str "\"" ++ str s ++ str "\""
-
-(** Invariant : exceptions embedded in EvaluatedError satisfy
- Errors.noncritical *)
-
-exception EvaluatedError of std_ppcmds * exn option
-
-(** Registration of generic errors
- Nota: explain_exn does NOT end with a newline anymore!
-*)
-
-let explain_exn_default = function
- (* Basic interaction exceptions *)
- | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".")
- | Compat.Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".")
- | CLexer.Error.E err -> hov 0 (str (CLexer.Error.to_string err))
- | Sys_error msg -> hov 0 (str "System error: " ++ guill msg)
- | Out_of_memory -> hov 0 (str "Out of memory.")
- | Stack_overflow -> hov 0 (str "Stack overflow.")
- | Timeout -> hov 0 (str "Timeout!")
- | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.")
- (* Exceptions with pre-evaluated error messages *)
- | EvaluatedError (msg,None) -> msg
- | EvaluatedError (msg,Some reraise) -> msg ++ CErrors.print reraise
- (* Otherwise, not handled here *)
- | _ -> raise CErrors.Unhandled
-
-let _ = CErrors.register_handler explain_exn_default
-
-
-(** Pre-explain a vernac interpretation error *)
-
-let wrap_vernac_error with_header (exn, info) strm =
- if with_header then
- let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in
- let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in
- (e, info)
- else
- (EvaluatedError (strm, None), info)
-
-let process_vernac_interp_error with_header exn = match fst exn with
- | Univ.UniverseInconsistency i ->
- let msg =
- if !Constrextern.print_universes then
- str "." ++ spc() ++
- Univ.explain_universe_inconsistency Universes.pr_with_global_universes i
- else
- mt() in
- wrap_vernac_error with_header exn (str "Universe inconsistency" ++ msg ++ str ".")
- | TypeError(ctx,te) ->
- wrap_vernac_error with_header exn (Himsg.explain_type_error ctx Evd.empty te)
- | PretypeError(ctx,sigma,te) ->
- wrap_vernac_error with_header exn (Himsg.explain_pretype_error ctx sigma te)
- | Typeclasses_errors.TypeClassError(env, te) ->
- wrap_vernac_error with_header exn (Himsg.explain_typeclass_error env te)
- | InductiveError e ->
- wrap_vernac_error with_header exn (Himsg.explain_inductive_error e)
- | Modops.ModuleTypingError e ->
- wrap_vernac_error with_header exn (Himsg.explain_module_error e)
- | Modintern.ModuleInternalizationError e ->
- wrap_vernac_error with_header exn (Himsg.explain_module_internalization_error e)
- | RecursionSchemeError e ->
- wrap_vernac_error with_header exn (Himsg.explain_recursion_scheme_error e)
- | Cases.PatternMatchingError (env,sigma,e) ->
- wrap_vernac_error with_header exn (Himsg.explain_pattern_matching_error env sigma e)
- | Tacred.ReductionTacticError e ->
- wrap_vernac_error with_header exn (Himsg.explain_reduction_tactic_error e)
- | Logic.RefinerError e ->
- wrap_vernac_error with_header exn (Himsg.explain_refiner_error e)
- | Nametab.GlobalizationError q ->
- wrap_vernac_error with_header exn
- (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++
- spc () ++ str "was not found" ++
- spc () ++ str "in the current" ++ spc () ++ str "environment.")
- | Refiner.FailError (i,s) ->
- let s = Lazy.force s in
- wrap_vernac_error with_header exn
- (str "Tactic failure" ++
- (if Pp.is_empty s then s else str ": " ++ s) ++
- if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").")
- | AlreadyDeclared msg ->
- wrap_vernac_error with_header exn (msg ++ str ".")
- | _ ->
- exn
-
-let rec strip_wrapping_exceptions = function
- | Logic_monad.TacticFailure e ->
- strip_wrapping_exceptions e
- | exc -> exc
-
-let additional_error_info = ref []
-
-let register_additional_error_info f =
- additional_error_info := f :: !additional_error_info
-
-let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, info) =
- let exc = strip_wrapping_exceptions exc in
- let e = process_vernac_interp_error with_header (exc, info) in
- let () =
- if not allow_uncaught && not (CErrors.handled (fst e)) then
- let (e, info) = e in
- let msg = str "Uncaught exception " ++ str (Printexc.to_string e) in
- let err = CErrors.make_anomaly msg in
- Util.iraise (err, info)
- in
- let e' =
- try Some (CList.find_map (fun f -> f e) !additional_error_info)
- with _ -> None
- in
- match e' with
- | None -> e
- | Some (None, loc) -> (fst e, Loc.add_loc (snd e) loc)
- | Some (Some msg, loc) ->
- (EvaluatedError (msg, Some (fst e)), Loc.add_loc (snd e) loc)
diff --git a/toplevel/explainErr.mli b/toplevel/explainErr.mli
deleted file mode 100644
index a67c887a..00000000
--- a/toplevel/explainErr.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(** Toplevel Exception *)
-exception EvaluatedError of Pp.std_ppcmds * exn option
-
-(** Pre-explain a vernac interpretation error *)
-
-val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> Util.iexn -> Util.iexn
-
-(** General explain function. Should not be used directly now,
- see instead function [Errors.print] and variants *)
-
-val explain_exn_default : exn -> Pp.std_ppcmds
-
-val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option * Loc.t) option) -> unit
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
deleted file mode 100644
index f98505c3..00000000
--- a/toplevel/himsg.ml
+++ /dev/null
@@ -1,1267 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Namegen
-open Term
-open Termops
-open Indtypes
-open Environ
-open Pretype_errors
-open Type_errors
-open Typeclasses_errors
-open Indrec
-open Cases
-open Logic
-open Printer
-open Evd
-open Context.Rel.Declaration
-
-(* This simplifies the typing context of Cases clauses *)
-(* hope it does not disturb other typing contexts *)
-let contract env lc =
- let l = ref [] in
- let contract_context decl env =
- match decl with
- | LocalDef (_,c',_) when isRel c' ->
- l := (Vars.substl !l c') :: !l;
- env
- | _ ->
- let t' = Vars.substl !l (get_type decl) in
- let c' = Option.map (Vars.substl !l) (get_value decl) in
- let na' = named_hd env t' (get_name decl) in
- l := (mkRel 1) :: List.map (Vars.lift 1) !l;
- match c' with
- | None -> push_rel (LocalAssum (na',t')) env
- | Some c' -> push_rel (LocalDef (na',c',t')) env
- in
- let env = process_rel_context contract_context env in
- (env, List.map (Vars.substl !l) lc)
-
-let contract2 env a b = match contract env [a;b] with
- | env, [a;b] -> env,a,b | _ -> assert false
-
-let contract3 env a b c = match contract env [a;b;c] with
- | env, [a;b;c] -> env,a,b,c | _ -> assert false
-
-let contract4 env a b c d = match contract env [a;b;c;d] with
- | env, [a;b;c;d] -> (env,a,b,c),d | _ -> assert false
-
-let contract1_vect env a v =
- match contract env (a :: Array.to_list v) with
- | env, a::l -> env,a,Array.of_list l
- | _ -> assert false
-
-let rec contract3' env a b c = function
- | OccurCheck (evk,d) -> let x,d = contract4 env a b c d in x,OccurCheck(evk,d)
- | NotClean ((evk,args),env',d) ->
- let env',d,args = contract1_vect env' d args in
- contract3 env a b c,NotClean((evk,args),env',d)
- | ConversionFailed (env',t1,t2) ->
- let (env',t1,t2) = contract2 env' t1 t2 in
- contract3 env a b c, ConversionFailed (env',t1,t2)
- | NotSameArgSize | NotSameHead | NoCanonicalStructure
- | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities
- | UnifUnivInconsistency _ as x -> contract3 env a b c, x
- | CannotSolveConstraint ((pb,env',t,u),x) ->
- let env',t,u = contract2 env' t u in
- let y,x = contract3' env a b c x in
- y,CannotSolveConstraint ((pb,env',t,u),x)
-
-(** Ad-hoc reductions *)
-
-let j_nf_betaiotaevar sigma j =
- { uj_val = Evarutil.nf_evar sigma j.uj_val;
- uj_type = Reductionops.nf_betaiota sigma j.uj_type }
-
-let jv_nf_betaiotaevar sigma jl =
- Array.map (j_nf_betaiotaevar sigma) jl
-
-(** Printers *)
-
-let pr_lconstr c = quote (pr_lconstr c)
-let pr_lconstr_env e s c = quote (pr_lconstr_env e s c)
-let pr_ljudge_env e s c = let v,t = pr_ljudge_env e s c in (quote v,quote t)
-
-(** A canonisation procedure for constr such that comparing there
- externalisation catches more equalities *)
-let canonize_constr c =
- (* replaces all the names in binders by [dn] ("default name"),
- ensures that [alpha]-equivalent terms will have the same
- externalisation. *)
- let dn = Name.Anonymous in
- let rec canonize_binders c =
- match Term.kind_of_term c with
- | Prod (_,t,b) -> mkProd(dn,t,b)
- | Lambda (_,t,b) -> mkLambda(dn,t,b)
- | LetIn (_,u,t,b) -> mkLetIn(dn,u,t,b)
- | _ -> Term.map_constr canonize_binders c
- in
- canonize_binders c
-
-(** Tries to realize when the two terms, albeit different are printed the same. *)
-let display_eq ~flags env sigma t1 t2 =
- (* terms are canonized, then their externalisation is compared syntactically *)
- let open Constrextern in
- let t1 = canonize_constr t1 in
- let t2 = canonize_constr t2 in
- let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) () in
- let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () in
- Constrexpr_ops.constr_expr_eq ct1 ct2
-
-(** This function adds some explicit printing flags if the two arguments are
- printed alike. *)
-let rec pr_explicit_aux env sigma t1 t2 = function
-| [] ->
- (** no specified flags: default. *)
- (quote (Printer.pr_lconstr_env env sigma t1), quote (Printer.pr_lconstr_env env sigma t2))
-| flags :: rem ->
- let equal = display_eq ~flags env sigma t1 t2 in
- if equal then
- (** The two terms are the same from the user point of view *)
- pr_explicit_aux env sigma t1 t2 rem
- else
- let open Constrextern in
- let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) ()
- in
- let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) ()
- in
- quote (Ppconstr.pr_lconstr_expr ct1), quote (Ppconstr.pr_lconstr_expr ct2)
-
-let explicit_flags =
- let open Constrextern in
- [ []; (** First, try with the current flags *)
- [print_implicits]; (** Then with implicit *)
- [print_universes]; (** Then with universes *)
- [print_universes; print_implicits]; (** With universes AND implicits *)
- [print_implicits; print_coercions; print_no_symbol]; (** Then more! *)
- [print_universes; print_implicits; print_coercions; print_no_symbol] (** and more! *) ]
-
-let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags
-
-let pr_db env i =
- try
- match lookup_rel i env |> get_name with
- | Name id -> pr_id id
- | Anonymous -> str "<>"
- with Not_found -> str "UNBOUND_REL_" ++ int i
-
-let explain_unbound_rel env sigma n =
- let pe = pr_ne_context_of (str "In environment") env sigma in
- str "Unbound reference: " ++ pe ++
- str "The reference " ++ int n ++ str " is free."
-
-let explain_unbound_var env v =
- let var = pr_id v in
- 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 () ++
- str "has type" ++ spc () ++ pt ++ spc () ++
- str "which should be Set, Prop or Type."
-
-let explain_bad_assumption env sigma j =
- let pe = pr_ne_context_of (str "In environment") env sigma in
- let pc,pt = pr_ljudge_env env sigma j in
- pe ++ str "Cannot declare a variable or hypothesis over the term" ++
- brk(1,1) ++ pc ++ spc () ++ str "of type" ++ spc () ++ pt ++ spc () ++
- str "because this term is not a type."
-
-let explain_reference_variables id c =
- (* c is intended to be a global reference *)
- let pc = pr_global (Globnames.global_of_constr c) in
- pc ++ strbrk " depends on the variable " ++ pr_id id ++
- strbrk " which is not declared in the context."
-
-let rec pr_disjunction pr = function
- | [a] -> pr a
- | [a;b] -> pr a ++ str " or" ++ spc () ++ pr b
- | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l
- | [] -> assert false
-
-let pr_puniverses f env (c,u) =
- f env c ++
- (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then
- str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)"
- else mt())
-
-let explain_elim_arity env sigma ind sorts c pj okinds =
- let env = make_all_name_different env in
- let pi = pr_inductive env (fst ind) in
- let pc = pr_lconstr_env env sigma c in
- let msg = match okinds with
- | Some(kp,ki,explanation) ->
- let pki = pr_sort_family ki in
- let pkp = pr_sort_family kp in
- let explanation = match explanation with
- | NonInformativeToInformative ->
- "proofs can be eliminated only to build proofs"
- | StrongEliminationOnNonSmallType ->
- "strong elimination on non-small inductive types leads to paradoxes"
- | WrongArity ->
- "wrong arity" in
- let ppar = pr_disjunction (fun s -> quote (pr_sort_family s)) sorts in
- let ppt = pr_lconstr_env env sigma ((strip_prod_assum pj.uj_type)) in
- hov 0
- (str "the return type has sort" ++ spc () ++ ppt ++ spc () ++
- str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++
- fnl () ++
- hov 0
- (str "Elimination of an inductive object of sort " ++
- pki ++ brk(1,0) ++
- str "is not allowed on a predicate in sort " ++ pkp ++ fnl () ++
- str "because" ++ spc () ++ str explanation ++ str ".")
- | None ->
- str "ill-formed elimination predicate."
- in
- hov 0 (
- str "Incorrect elimination of" ++ spc () ++ pc ++ spc () ++
- str "in the inductive type" ++ spc () ++ quote pi ++ str ":") ++
- 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 in
- let pc = pr_lconstr_env env sigma cj.uj_val in
- let pct = pr_lconstr_env env sigma cj.uj_type in
- match kind_of_term cj.uj_type with
- | Evar _ ->
- str "Cannot infer a type for this expression."
- | _ ->
- str "The term" ++ brk(1,1) ++ pc ++ spc () ++
- str "has type" ++ brk(1,1) ++ pct ++ spc () ++
- 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 in
- let pc = pr_lconstr_env env sigma cj.uj_val in
- let pct = pr_lconstr_env env sigma cj.uj_type in
- str "Matching on term" ++ brk(1,1) ++ pc ++ spc () ++
- str "of type" ++ brk(1,1) ++ pct ++ spc () ++
- str "expects " ++ int expn ++ str " branches."
-
-let explain_ill_formed_branch env sigma c ci actty expty =
- let simp t = Reduction.nf_betaiota env (Evarutil.nf_evar sigma t) in
- let c = Evarutil.nf_evar sigma c in
- let env = make_all_name_different env in
- let pc = pr_lconstr_env env sigma c in
- let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in
- strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++
- spc () ++ strbrk "the branch for constructor" ++ spc () ++
- quote (pr_puniverses pr_constructor env ci) ++
- spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++
- str "which should be" ++ brk(1,1) ++ pe ++ str "."
-
-let explain_generalization env sigma (name,var) j =
- let pe = pr_ne_context_of (str "In environment") env sigma in
- let pv = pr_ltype_env env sigma var in
- let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) env) sigma j in
- pe ++ str "Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++
- str "over" ++ brk(1,1) ++ pc ++ str "," ++ spc () ++
- str "it has type" ++ spc () ++ pt ++
- spc () ++ str "which should be Set, Prop or Type."
-
-let explain_unification_error env sigma p1 p2 = function
- | None -> mt()
- | Some e ->
- let rec aux p1 p2 = function
- | OccurCheck (evk,rhs) ->
- let rhs = Evarutil.nf_evar sigma rhs in
- [str "cannot define " ++ quote (pr_existential_key sigma evk) ++
- strbrk " with term " ++ pr_lconstr_env env sigma rhs ++
- strbrk " that would depend on itself"]
- | NotClean ((evk,args),env,c) ->
- let c = Evarutil.nf_evar sigma c in
- let args = Array.map (Evarutil.nf_evar sigma) args in
- [str "cannot instantiate " ++ quote (pr_existential_key sigma evk)
- ++ strbrk " because " ++ pr_lconstr_env env sigma c ++
- strbrk " is not in its scope" ++
- (if Array.is_empty args then mt() else
- strbrk ": available arguments are " ++
- pr_sequence (pr_lconstr_env env sigma) (List.rev (Array.to_list args)))]
- | NotSameArgSize | NotSameHead | NoCanonicalStructure ->
- (* Error speaks from itself *) []
- | ConversionFailed (env,t1,t2) ->
- if Term.eq_constr t1 p1 && Term.eq_constr t2 p2 then [] else
- let env = make_all_name_different env in
- let t1 = Evarutil.nf_evar sigma t1 in
- let t2 = Evarutil.nf_evar sigma t2 in
- if not (Term.eq_constr t1 p1) || not (Term.eq_constr t2 p2) then
- let t1, t2 = pr_explicit env sigma t1 t2 in
- [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2]
- else []
- | MetaOccurInBody evk ->
- [str "instance for " ++ quote (pr_existential_key sigma evk) ++
- strbrk " refers to a metavariable - please report your example" ++
- strbrk "at " ++ str Coq_config.wwwbugtracker ++ str "."]
- | InstanceNotSameType (evk,env,t,u) ->
- let t, u = pr_explicit env sigma t u in
- [str "unable to find a well-typed instantiation for " ++
- quote (pr_existential_key sigma evk) ++
- strbrk ": cannot ensure that " ++
- t ++ strbrk " is a subtype of " ++ u]
- | UnifUnivInconsistency p ->
- if !Constrextern.print_universes then
- [str "universe inconsistency: " ++
- Univ.explain_universe_inconsistency Universes.pr_with_global_universes p]
- else
- [str "universe inconsistency"]
- | CannotSolveConstraint ((pb,env,t,u),e) ->
- let t = Evarutil.nf_evar sigma t in
- let u = Evarutil.nf_evar sigma u in
- let env = make_all_name_different env in
- (strbrk "cannot satisfy constraint " ++ pr_lconstr_env env sigma t ++
- str " == " ++ pr_lconstr_env env sigma u)
- :: aux t u e
- | ProblemBeyondCapabilities ->
- []
- in
- match aux p1 p2 e with
- | [] -> mt ()
- | l -> spc () ++ str "(" ++
- prlist_with_sep pr_semicolon (fun x -> x) l ++ str ")"
-
-let explain_actual_type env sigma j t reason =
- let env = make_all_name_different env in
- let j = j_nf_betaiotaevar sigma j in
- let t = Reductionops.nf_betaiota sigma t in
- (** Actually print *)
- let pe = pr_ne_context_of (str "In environment") env sigma in
- let pc = pr_lconstr_env env sigma (Environ.j_val j) in
- let (pt, pct) = pr_explicit env sigma t (Environ.j_type j) in
- let ppreason = explain_unification_error env sigma j.uj_type t reason in
- pe ++
- hov 0 (
- str "The term" ++ brk(1,1) ++ pc ++ spc () ++
- str "has type" ++ brk(1,1) ++ pct ++ spc () ++
- str "while it is expected to have type" ++ brk(1,1) ++ pt ++
- ppreason ++ str ".")
-
-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 in
- let actualtyp, exptyp = pr_explicit env sigma actualtyp exptyp in
- let nargs = Array.length randl in
-(* let pe = pr_ne_context_of (str "in environment") env sigma in*)
- let pr,prt = pr_ljudge_env env sigma rator in
- let term_string1 = str (String.plural nargs "term") in
- let term_string2 =
- if nargs>1 then str "The " ++ pr_nth n ++ str " term" else str "This term"
- in
- let appl = prvect_with_sep fnl
- (fun c ->
- let pc,pct = pr_ljudge_env env sigma c in
- hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl
- in
- str "Illegal application: " ++ (* pe ++ *) fnl () ++
- str "The term" ++ brk(1,1) ++ pr ++ spc () ++
- str "of type" ++ brk(1,1) ++ prt ++ spc () ++
- str "cannot be applied to the " ++ term_string1 ++ fnl () ++
- str " " ++ v 0 appl ++ fnl () ++ term_string2 ++ str " has type" ++
- brk(1,1) ++ actualtyp ++ spc () ++
- str "which should be coercible to" ++ brk(1,1) ++
- 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 in
- let nargs = Array.length randl in
-(* let pe = pr_ne_context_of (str "in environment") env sigma in*)
- let pr = pr_lconstr_env env sigma rator.uj_val in
- let prt = pr_lconstr_env env sigma rator.uj_type in
- let appl = prvect_with_sep fnl
- (fun c ->
- let pc = pr_lconstr_env env sigma c.uj_val in
- let pct = pr_lconstr_env env sigma c.uj_type in
- hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl
- in
- str "Illegal application (Non-functional construction): " ++
- (* pe ++ *) fnl () ++
- str "The expression" ++ brk(1,1) ++ pr ++ spc () ++
- str "of type" ++ brk(1,1) ++ prt ++ spc () ++
- str "cannot be applied to the " ++ str (String.plural nargs "term") ++
- 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."
-
-let explain_not_product env sigma c =
- let c = Evarutil.nf_evar sigma c in
- 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 "."
-
-(* TODO: use the names *)
-(* (co)fixpoints *)
-let explain_ill_formed_rec_body env sigma err names i fixenv vdefj =
- let prt_name i =
- match names.(i) with
- Name id -> str "Recursive definition of " ++ pr_id id
- | Anonymous -> str "The " ++ pr_nth i ++ str " definition" in
-
- let st = match err with
-
- (* Fixpoint guard errors *)
- | NotEnoughAbstractionInFixBody ->
- str "Not enough abstractions in the definition"
- | RecursionNotOnInductiveType c ->
- str "Recursive definition on" ++ spc () ++ pr_lconstr_env env sigma c ++
- spc () ++ str "which should be an inductive type"
- | RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) ->
- let arg_env = make_all_name_different arg_env in
- let called =
- match names.(j) with
- Name id -> pr_id id
- | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in
- let pr_db x = quote (pr_db env x) in
- let vars =
- match (lt,le) with
- ([],[]) -> assert false
- | ([],[x]) -> str "a subterm of " ++ pr_db x
- | ([],_) -> str "a subterm of the following variables: " ++
- pr_sequence pr_db le
- | ([x],_) -> pr_db x
- | _ ->
- str "one of the following variables: " ++
- pr_sequence pr_db lt in
- str "Recursive call to " ++ called ++ spc () ++
- strbrk "has principal argument equal to" ++ spc () ++
- pr_lconstr_env arg_env sigma arg ++ strbrk " instead of " ++ vars
-
- | NotEnoughArgumentsForFixCall j ->
- let called =
- match names.(j) with
- Name id -> pr_id id
- | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in
- str "Recursive call to " ++ called ++ str " has not enough arguments"
-
- (* CoFixpoint guard errors *)
- | CodomainNotInductiveType c ->
- str "The codomain is" ++ spc () ++ pr_lconstr_env env sigma c ++ spc () ++
- str "which should be a coinductive type"
- | NestedRecursiveOccurrences ->
- str "Nested recursive occurrences"
- | UnguardedRecursiveCall c ->
- str "Unguarded recursive call in" ++ spc () ++ pr_lconstr_env env sigma c
- | RecCallInTypeOfAbstraction c ->
- str "Recursive call forbidden in the domain of an abstraction:" ++
- spc () ++ pr_lconstr_env env sigma c
- | RecCallInNonRecArgOfConstructor c ->
- str "Recursive call on a non-recursive argument of constructor" ++
- spc () ++ pr_lconstr_env env sigma c
- | RecCallInTypeOfDef c ->
- str "Recursive call forbidden in the type of a recursive definition" ++
- spc () ++ pr_lconstr_env env sigma c
- | RecCallInCaseFun c ->
- str "Invalid recursive call in a branch of" ++
- spc () ++ pr_lconstr_env env sigma c
- | RecCallInCaseArg c ->
- str "Invalid recursive call in the argument of \"match\" in" ++ spc () ++
- pr_lconstr_env env sigma c
- | RecCallInCasePred c ->
- str "Invalid recursive call in the \"return\" clause of \"match\" in" ++
- spc () ++ pr_lconstr_env env sigma c
- | NotGuardedForm c ->
- str "Sub-expression " ++ pr_lconstr_env env sigma c ++
- strbrk " not in guarded form (should be a constructor," ++
- strbrk " an abstraction, a match, a cofix or a recursive call)"
- | ReturnPredicateNotCoInductive c ->
- str "The return clause of the following pattern matching should be" ++
- strbrk " a coinductive type:" ++
- spc () ++ pr_lconstr_env env sigma c
- in
- prt_name i ++ str " is ill-formed." ++ fnl () ++
- pr_ne_context_of (str "In environment") env sigma ++
- st ++ str "." ++ fnl () ++
- (try (* May fail with unresolved globals. *)
- let fixenv = make_all_name_different fixenv in
- let pvd = pr_lconstr_env fixenv sigma vdefj.(i).uj_val in
- str"Recursive definition is:" ++ spc () ++ pvd ++ str "."
- 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 in
- let pvd = pr_lconstr_env env sigma vdefj.(i).uj_val in
- let pvdt, pv = pr_explicit env sigma vdefj.(i).uj_type vargs.(i) in
- str "The " ++
- (match vdefj with [|_|] -> mt () | _ -> pr_nth (i+1) ++ spc ()) ++
- str "recursive definition" ++ spc () ++ pvd ++ spc () ++
- str "has type" ++ spc () ++ pvdt ++ spc () ++
- str "while it should be" ++ spc () ++ pv ++ str "."
-
-let explain_cant_find_case_type env sigma c =
- let c = Evarutil.nf_evar sigma c in
- let env = make_all_name_different env in
- let pe = pr_lconstr_env env sigma c in
- str "Cannot infer the return type of pattern-matching on" ++ ws 1 ++
- pe ++ str "."
-
-let explain_occur_check env sigma ev rhs =
- let rhs = Evarutil.nf_evar sigma rhs in
- let env = make_all_name_different env in
- let pt = pr_lconstr_env env sigma rhs in
- str "Cannot define " ++ pr_existential_key sigma ev ++ str " with term" ++
- brk(1,1) ++ pt ++ spc () ++ str "that would depend on itself."
-
-let pr_trailing_ne_context_of env sigma =
- if List.is_empty (Environ.rel_context env) &&
- List.is_empty (Environ.named_context env)
- then str "."
- else (str " in environment:"++ pr_context_unlimited env sigma)
-
-let rec explain_evar_kind env sigma evk ty = function
- | Evar_kinds.QuestionMark _ ->
- strbrk "this placeholder of type " ++ ty
- | Evar_kinds.CasesType false ->
- strbrk "the type of this pattern-matching problem"
- | Evar_kinds.CasesType true ->
- strbrk "a subterm of type " ++ ty ++
- strbrk " in the type of this pattern-matching problem"
- | Evar_kinds.BinderType (Name id) ->
- strbrk "the type of " ++ Nameops.pr_id id
- | Evar_kinds.BinderType Anonymous ->
- strbrk "the type of this anonymous binder"
- | Evar_kinds.ImplicitArg (c,(n,ido),b) ->
- let id = Option.get ido in
- strbrk "the implicit parameter " ++ pr_id id ++ spc () ++ str "of" ++
- spc () ++ Nametab.pr_global_env Id.Set.empty c ++
- strbrk " whose type is " ++ ty
- | Evar_kinds.InternalHole -> strbrk "an internal placeholder of type " ++ ty
- | Evar_kinds.TomatchTypeParameter (tyi,n) ->
- strbrk "the " ++ pr_nth n ++
- strbrk " argument of the inductive type (" ++ pr_inductive env tyi ++
- strbrk ") of this term"
- | Evar_kinds.GoalEvar ->
- strbrk "an existential variable of type " ++ ty
- | Evar_kinds.ImpossibleCase ->
- strbrk "the type of an impossible pattern-matching clause"
- | Evar_kinds.MatchingVar _ ->
- assert false
- | Evar_kinds.VarInstance id ->
- strbrk "an instance of type " ++ ty ++
- str " for the variable " ++ pr_id id
- | Evar_kinds.SubEvar evk' ->
- let evi = Evd.find sigma evk' in
- let pc = match evi.evar_body with
- | Evar_defined c -> pr_lconstr_env env sigma (Evarutil.nf_evar sigma c)
- | Evar_empty -> assert false in
- let ty' = Evarutil.nf_evar sigma 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'
- (pr_lconstr_env env sigma ty') (snd evi.evar_source)
-
-let explain_typeclass_resolution env sigma evi k =
- match Typeclasses.class_of_constr evi.evar_concl with
- | Some _ ->
- let env = Evd.evar_filtered_env evi in
- fnl () ++ str "Could not find an instance for " ++
- pr_lconstr_env env sigma evi.evar_concl ++
- pr_trailing_ne_context_of env sigma
- | _ -> mt()
-
-let explain_placeholder_kind env sigma c e =
- match e with
- | Some (SeveralInstancesFound n) ->
- strbrk " (several distinct possible type class instances found)"
- | None ->
- match Typeclasses.class_of_constr c with
- | Some _ -> strbrk " (no type class instance found)"
- | _ -> mt ()
-
-let explain_unsolvable_implicit env sigma evk explain =
- let evi = Evarutil.nf_evar_info sigma (Evd.find_undefined sigma evk) in
- let env = Evd.evar_filtered_env evi in
- let type_of_hole = pr_lconstr_env env sigma evi.evar_concl in
- let pe = pr_trailing_ne_context_of env sigma in
- strbrk "Cannot infer " ++
- explain_evar_kind env sigma evk type_of_hole (snd evi.evar_source) ++
- explain_placeholder_kind env sigma evi.evar_concl explain ++ pe
-
-let explain_var_not_found env id =
- str "The variable" ++ spc () ++ pr_id id ++
- spc () ++ str "was not found" ++
- spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "."
-
-let explain_wrong_case_info env (ind,u) ci =
- let pi = pr_inductive (Global.env()) ind in
- if eq_ind ci.ci_ind ind then
- str "Pattern-matching expression on an object of inductive type" ++
- spc () ++ pi ++ spc () ++ str "has invalid information."
- else
- let pc = pr_inductive (Global.env()) ci.ci_ind in
- str "A term of inductive type" ++ spc () ++ pi ++ spc () ++
- str "was given to a pattern-matching expression on the inductive type" ++
- spc () ++ pc ++ str "."
-
-let explain_cannot_unify env sigma m n e =
- let env = make_all_name_different env 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
- pe ++ str "Unable to unify" ++ brk(1,1) ++ pm ++ spc () ++
- str "with" ++ brk(1,1) ++ pn ++ ppreason ++ str "."
-
-let explain_cannot_unify_local env sigma m n subn =
- let pm = pr_lconstr_env env sigma m in
- let pn = pr_lconstr_env env sigma n in
- let psubn = pr_lconstr_env env sigma subn in
- str "Unable to unify" ++ brk(1,1) ++ pm ++ spc () ++
- str "with" ++ brk(1,1) ++ pn ++ spc () ++ str "as" ++ brk(1,1) ++
- psubn ++ str " contains local variables."
-
-let explain_refiner_cannot_generalize env sigma ty =
- str "Cannot find a well-typed generalisation of the goal with type: " ++
- pr_lconstr_env env sigma ty ++ str "."
-
-let explain_no_occurrence_found env sigma c id =
- str "Found no subterm matching " ++ pr_lconstr_env env sigma c ++
- str " in " ++
- (match id with
- | Some id -> pr_id id
- | None -> str"the current goal") ++ str "."
-
-let explain_cannot_unify_binding_type env sigma m n =
- let pm = pr_lconstr_env env sigma m in
- let pn = pr_lconstr_env env sigma n in
- str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++
- str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "."
-
-let explain_cannot_find_well_typed_abstraction env sigma p l e =
- str "Abstracting over the " ++
- str (String.plural (List.length l) "term") ++ spc () ++
- hov 0 (pr_enum (pr_lconstr_env env sigma) l) ++ spc () ++
- str "leads to a term" ++ spc () ++ pr_lconstr_goal_style_env env sigma p ++
- spc () ++ str "which is ill-typed." ++
- (match e with None -> mt () | Some e -> fnl () ++ str "Reason is: " ++ e)
-
-let explain_wrong_abstraction_type env sigma na abs expected result =
- let ppname = match na with Name id -> pr_id id ++ spc () | _ -> mt () in
- str "Cannot instantiate metavariable " ++ ppname ++ strbrk "of type " ++
- pr_lconstr_env env sigma expected ++ strbrk " with abstraction " ++
- pr_lconstr_env env sigma abs ++ strbrk " of incompatible type " ++
- pr_lconstr_env env sigma result ++ str "."
-
-let explain_abstraction_over_meta _ m n =
- strbrk "Too complex unification problem: cannot find a solution for both " ++
- pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "."
-
-let explain_non_linear_unification env sigma m t =
- strbrk "Cannot unambiguously instantiate " ++
- pr_name m ++ str ":" ++
- strbrk " which would require to abstract twice on " ++
- pr_lconstr_env env sigma t ++ str "."
-
-let explain_unsatisfied_constraints env sigma cst =
- strbrk "Unsatisfied constraints: " ++
- Univ.pr_constraints (Evd.pr_evd_level sigma) cst ++
- spc () ++ str "(maybe a bugged tactic)."
-
-let explain_type_error env sigma err =
- let env = make_all_name_different env in
- match err with
- | UnboundRel n ->
- explain_unbound_rel env sigma n
- | UnboundVar v ->
- explain_unbound_var env v
- | NotAType j ->
- explain_not_type env sigma j
- | BadAssumption c ->
- explain_bad_assumption env sigma c
- | ReferenceVariables (id,c) ->
- explain_reference_variables id c
- | ElimArity (ind, aritylst, c, pj, okinds) ->
- explain_elim_arity env sigma ind aritylst c pj okinds
- | CaseNotInductive cj ->
- explain_case_not_inductive env sigma cj
- | NumberBranches (cj, n) ->
- explain_number_branches env sigma cj n
- | IllFormedBranch (c, i, actty, expty) ->
- explain_ill_formed_branch env sigma c i actty expty
- | Generalization (nvar, c) ->
- explain_generalization env sigma nvar c
- | ActualType (j, pt) ->
- explain_actual_type env sigma j pt None
- | CantApplyBadType (t, rator, randl) ->
- explain_cant_apply_bad_type env sigma t rator randl
- | CantApplyNonFunctional (rator, randl) ->
- explain_cant_apply_not_functional env sigma rator randl
- | IllFormedRecBody (err, lna, i, fixenv, vdefj) ->
- explain_ill_formed_rec_body env sigma err lna i fixenv vdefj
- | IllTypedRecBody (i, lna, vdefj, vargs) ->
- explain_ill_typed_rec_body env sigma i lna vdefj vargs
- | WrongCaseInfo (ind,ci) ->
- explain_wrong_case_info env ind ci
- | UnsatisfiedConstraints cst ->
- explain_unsatisfied_constraints env sigma cst
-
-let pr_position (cl,pos) =
- let clpos = match cl with
- | None -> str " of the goal"
- | Some (id,Locus.InHyp) -> str " of hypothesis " ++ pr_id id
- | Some (id,Locus.InHypTypeOnly) -> str " of the type of hypothesis " ++ pr_id id
- | Some (id,Locus.InHypValueOnly) -> str " of the body of hypothesis " ++ pr_id id in
- int pos ++ clpos
-
-let explain_cannot_unify_occurrences env sigma nested ((cl2,pos2),t2) ((cl1,pos1),t1) e =
- if nested then
- str "Found nested occurrences of the pattern at positions " ++
- int pos1 ++ strbrk " and " ++ pr_position (cl2,pos2) ++ str "."
- else
- let ppreason = match e with None -> mt() | Some (c1,c2,e) -> explain_unification_error env sigma c1 c2 (Some e) in
- str "Found incompatible occurrences of the pattern" ++ str ":" ++
- spc () ++ str "Matched term " ++ pr_lconstr_env env sigma t2 ++
- strbrk " at position " ++ pr_position (cl2,pos2) ++
- strbrk " is not compatible with matched term " ++
- pr_lconstr_env env sigma t1 ++ strbrk " at position " ++
- pr_position (cl1,pos1) ++ ppreason ++ str "."
-
-let pr_constraints printenv env sigma evars cstrs =
- let (ev, evi) = Evar.Map.choose evars in
- if Evar.Map.for_all (fun ev' evi' ->
- eq_named_context_val evi.evar_hyps evi'.evar_hyps) evars
- then
- let l = Evar.Map.bindings evars in
- let env' = reset_with_named_context evi.evar_hyps env in
- let pe =
- if printenv then
- pr_ne_context_of (str "In environment:") env' sigma
- else mt ()
- in
- let evs =
- prlist
- (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++
- str " : " ++ pr_lconstr_env env' sigma evi.evar_concl ++ fnl ()) l
- in
- h 0 (pe ++ evs ++ pr_evar_constraints cstrs)
- else
- let filter evk _ = Evar.Map.mem evk evars in
- pr_evar_map_filter ~with_univs:false filter sigma
-
-let explain_unsatisfiable_constraints env sigma constr comp =
- let (_, constraints) = Evd.extract_all_conv_pbs sigma in
- let undef = Evd.undefined_map (Evarutil.nf_evar_map_undefined sigma) in
- (** Only keep evars that are subject to resolution and members of the given
- component. *)
- let is_kept evk evi = match comp with
- | None -> Typeclasses.is_resolvable evi
- | Some comp -> Typeclasses.is_resolvable evi && Evar.Set.mem evk comp
- in
- let undef =
- let m = Evar.Map.filter is_kept undef in
- if Evar.Map.is_empty m then undef
- else m
- in
- match constr with
- | None ->
- str "Unable to satisfy the following constraints:" ++ fnl () ++
- pr_constraints true env sigma undef constraints
- | Some (ev, k) ->
- let cstr =
- let remaining = Evar.Map.remove ev undef in
- if not (Evar.Map.is_empty remaining) then
- str "With the following constraints:" ++ fnl () ++
- pr_constraints false env sigma remaining constraints
- else mt ()
- in
- let info = Evar.Map.find ev undef in
- explain_typeclass_resolution env sigma info k ++ fnl () ++ cstr
-
-let explain_pretype_error env sigma err =
- let env = Evardefine.env_nf_betaiotaevar sigma env in
- let env = make_all_name_different env in
- match err with
- | CantFindCaseType c -> explain_cant_find_case_type env sigma c
- | ActualTypeNotCoercible (j,t,e) ->
- let {uj_val = c; uj_type = actty} = j in
- let (env, c, actty, expty), e = contract3' env c actty t e in
- let j = {uj_val = c; uj_type = actty} in
- explain_actual_type env sigma j expty (Some e)
- | UnifOccurCheck (ev,rhs) -> explain_occur_check env sigma ev rhs
- | UnsolvableImplicit (evk,exp) -> explain_unsolvable_implicit env sigma evk exp
- | VarNotFound id -> explain_var_not_found env id
- | UnexpectedType (actual,expect) ->
- let env, actual, expect = contract2 env actual expect in
- explain_unexpected_type env sigma actual expect
- | NotProduct c -> explain_not_product env sigma c
- | CannotUnify (m,n,e) ->
- let env, m, n = contract2 env m n in
- explain_cannot_unify env sigma m n e
- | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env sigma m n sn
- | CannotGeneralize ty -> explain_refiner_cannot_generalize env sigma ty
- | NoOccurrenceFound (c, id) -> explain_no_occurrence_found env sigma c id
- | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env sigma m n
- | CannotFindWellTypedAbstraction (p,l,e) ->
- explain_cannot_find_well_typed_abstraction env sigma p l
- (Option.map (fun (env',e) -> explain_type_error env' sigma e) e)
- | WrongAbstractionType (n,a,t,u) ->
- explain_wrong_abstraction_type env sigma n a t u
- | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n
- | NonLinearUnification (m,c) -> explain_non_linear_unification env sigma m c
- | TypingError t -> explain_type_error env sigma t
- | CannotUnifyOccurrences (b,c1,c2,e) -> explain_cannot_unify_occurrences env sigma b c1 c2 e
- | UnsatisfiableConstraints (c,comp) -> explain_unsatisfiable_constraints env sigma c comp
-(* Module errors *)
-
-open Modops
-
-let explain_not_match_error = function
- | InductiveFieldExpected _ ->
- strbrk "an inductive definition is expected"
- | DefinitionFieldExpected ->
- strbrk "a definition is expected"
- | ModuleFieldExpected ->
- strbrk "a module is expected"
- | ModuleTypeFieldExpected ->
- strbrk "a module type is expected"
- | NotConvertibleInductiveField id | NotConvertibleConstructorField id ->
- str "types given to " ++ pr_id id ++ str " differ"
- | NotConvertibleBodyField ->
- str "the body of definitions differs"
- | NotConvertibleTypeField (env, typ1, typ2) ->
- str "expected type" ++ spc () ++
- quote (Printer.safe_pr_lconstr_env env Evd.empty typ2) ++ spc () ++
- str "but found type" ++ spc () ++
- quote (Printer.safe_pr_lconstr_env env Evd.empty typ1)
- | NotSameConstructorNamesField ->
- str "constructor names differ"
- | NotSameInductiveNameInBlockField ->
- str "inductive types names differ"
- | FiniteInductiveFieldExpected isfinite ->
- str "type is expected to be " ++
- str (if isfinite then "coinductive" else "inductive")
- | InductiveNumbersFieldExpected n ->
- str "number of inductive types differs"
- | InductiveParamsNumberField n ->
- str "inductive type has not the right number of parameters"
- | RecordFieldExpected isrecord ->
- str "type is expected " ++ str (if isrecord then "" else "not ") ++
- str "to be a record"
- | RecordProjectionsExpected nal ->
- (if List.length nal >= 2 then str "expected projection names are "
- else str "expected projection name is ") ++
- pr_enum (function Name id -> pr_id id | _ -> str "_") nal
- | NotEqualInductiveAliases ->
- str "Aliases to inductive types do not match"
- | NoTypeConstraintExpected ->
- strbrk "a definition whose type is constrained can only be subtype " ++
- strbrk "of a definition whose type is itself constrained"
- | PolymorphicStatusExpected b ->
- let status b = if b then str"polymorphic" else str"monomorphic" in
- str "a " ++ status b ++ str" declaration was expected, but a " ++
- status (not b) ++ str" declaration was found"
- | IncompatibleInstances ->
- str"polymorphic universe instances do not match"
- | IncompatibleUniverses incon ->
- str"the universe constraints are inconsistent: " ++
- Univ.explain_universe_inconsistency Universes.pr_with_global_universes incon
- | IncompatiblePolymorphism (env, t1, t2) ->
- str "conversion of polymorphic values generates additional constraints: " ++
- quote (Printer.safe_pr_lconstr_env env Evd.empty t1) ++ spc () ++
- str "compared to " ++ spc () ++
- quote (Printer.safe_pr_lconstr_env env Evd.empty t2)
- | IncompatibleConstraints cst ->
- str " the expected (polymorphic) constraints do not imply " ++
- quote (Univ.pr_constraints (Evd.pr_evd_level Evd.empty) cst)
-
-let explain_signature_mismatch l spec why =
- str "Signature components for label " ++ pr_label l ++
- str " do not match:" ++ spc () ++ explain_not_match_error why ++ str "."
-
-let explain_label_already_declared l =
- str "The label " ++ pr_label l ++ str " is already declared."
-
-let explain_application_to_not_path _ =
- strbrk "A module cannot be applied to another module application or " ++
- strbrk "with-expression; you must give a name to the intermediate result " ++
- strbrk "module first."
-
-let explain_not_a_functor () =
- str "Application of a non-functor."
-
-let explain_is_a_functor () =
- str "Illegal use of a functor."
-
-let explain_incompatible_module_types mexpr1 mexpr2 =
- let open Declarations in
- let rec get_arg = function
- | NoFunctor _ -> 0
- | MoreFunctor (_, _, ty) -> succ (get_arg ty)
- in
- let len1 = get_arg mexpr1.mod_type in
- let len2 = get_arg mexpr2.mod_type in
- if len1 <> len2 then
- str "Incompatible module types: module expects " ++ int len2 ++
- str " arguments, found " ++ int len1 ++ str "."
- else str "Incompatible module types."
-
-let explain_not_equal_module_paths mp1 mp2 =
- str "Non equal modules."
-
-let explain_no_such_label l =
- str "No such label " ++ pr_label l ++ str "."
-
-let explain_incompatible_labels l l' =
- str "Opening and closing labels are not the same: " ++
- pr_label l ++ str " <> " ++ pr_label l' ++ str "!"
-
-let explain_not_a_module s =
- quote (str s) ++ str " is not a module."
-
-let explain_not_a_module_type s =
- quote (str s) ++ str " is not a module type."
-
-let explain_not_a_constant l =
- quote (pr_label l) ++ str " is not a constant."
-
-let explain_incorrect_label_constraint l =
- str "Incorrect constraint for label " ++
- quote (pr_label l) ++ str "."
-
-let explain_generative_module_expected l =
- str "The module " ++ pr_label l ++ str " is not generative." ++
- strbrk " Only components of generative modules can be changed" ++
- strbrk " using the \"with\" construct."
-
-let explain_label_missing l s =
- str "The field " ++ pr_label l ++ str " is missing in "
- ++ str s ++ str "."
-
-let explain_include_restricted_functor mp =
- let q = Nametab.shortest_qualid_of_module mp in
- str "Cannot include the functor " ++ Libnames.pr_qualid q ++
- strbrk " since it has a restricted signature. " ++
- strbrk "You may name first an instance of this functor, and include it."
-
-let explain_module_error = function
- | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err
- | LabelAlreadyDeclared l -> explain_label_already_declared l
- | ApplicationToNotPath mexpr -> explain_application_to_not_path mexpr
- | NotAFunctor -> explain_not_a_functor ()
- | IsAFunctor -> explain_is_a_functor ()
- | IncompatibleModuleTypes (m1,m2) -> explain_incompatible_module_types m1 m2
- | NotEqualModulePaths (mp1,mp2) -> explain_not_equal_module_paths mp1 mp2
- | NoSuchLabel l -> explain_no_such_label l
- | IncompatibleLabels (l1,l2) -> explain_incompatible_labels l1 l2
- | NotAModule s -> explain_not_a_module s
- | NotAModuleType s -> explain_not_a_module_type s
- | NotAConstant l -> explain_not_a_constant l
- | IncorrectWithConstraint l -> explain_incorrect_label_constraint l
- | GenerativeModuleExpected l -> explain_generative_module_expected l
- | LabelMissing (l,s) -> explain_label_missing l s
- | IncludeRestrictedFunctor mp -> explain_include_restricted_functor mp
-
-(* Module internalization errors *)
-
-(*
-let explain_declaration_not_path _ =
- str "Declaration is not a path."
-
-*)
-
-let explain_not_module_nor_modtype s =
- quote (str s) ++ str " is not a module or module type."
-
-let explain_incorrect_with_in_module () =
- str "The syntax \"with\" is not allowed for modules."
-
-let explain_incorrect_module_application () =
- str "Illegal application to a module type."
-
-open Modintern
-
-let explain_module_internalization_error = function
- | NotAModuleNorModtype s -> explain_not_module_nor_modtype s
- | IncorrectWithInModule -> explain_incorrect_with_in_module ()
- | IncorrectModuleApplication -> explain_incorrect_module_application ()
-
-(* Typeclass errors *)
-
-let explain_not_a_class env c =
- pr_constr_env env Evd.empty c ++ str" is not a declared type class."
-
-let explain_unbound_method env cid id =
- str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++
- str"of class" ++ spc () ++ pr_global cid ++ str "."
-
-let pr_constr_exprs exprs =
- hv 0 (List.fold_right
- (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps)
- exprs (mt ()))
-
-let explain_mismatched_contexts env c i j =
- str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++
- hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env Evd.empty j) ++
- fnl () ++ brk (1,1) ++
- hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i)
-
-let explain_typeclass_error env = function
- | NotAClass c -> explain_not_a_class env c
- | UnboundMethod (cid, id) -> explain_unbound_method env cid id
- | MismatchedContextInstance (c,i,j) -> explain_mismatched_contexts env c i j
-
-(* Refiner errors *)
-
-let explain_refiner_bad_type arg ty conclty =
- str "Refiner was given an argument" ++ brk(1,1) ++
- pr_lconstr arg ++ spc () ++
- str "of type" ++ brk(1,1) ++ pr_lconstr ty ++ spc () ++
- str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "."
-
-let explain_refiner_unresolved_bindings l =
- str "Unable to find an instance for the " ++
- str (String.plural (List.length l) "variable") ++ spc () ++
- prlist_with_sep pr_comma pr_name l ++ str"."
-
-let explain_refiner_cannot_apply t harg =
- str "In refiner, a term of type" ++ brk(1,1) ++
- pr_lconstr t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++
- pr_lconstr harg ++ str "."
-
-let explain_refiner_not_well_typed c =
- str "The term " ++ pr_lconstr c ++ str " is not well-typed."
-
-let explain_intro_needs_product () =
- str "Introduction tactics needs products."
-
-let explain_does_not_occur_in c hyp =
- str "The term" ++ spc () ++ pr_lconstr c ++ spc () ++
- str "does not occur in" ++ spc () ++ pr_id hyp ++ str "."
-
-let explain_non_linear_proof c =
- str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr c ++
- spc () ++ str "because a metavariable has several occurrences."
-
-let explain_meta_in_type c =
- str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++
- str " of another meta"
-
-let explain_no_such_hyp id =
- str "No such hypothesis: " ++ pr_id id
-
-let explain_refiner_error = function
- | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty
- | UnresolvedBindings t -> explain_refiner_unresolved_bindings t
- | CannotApply (t,harg) -> explain_refiner_cannot_apply t harg
- | NotWellTyped c -> explain_refiner_not_well_typed c
- | IntroNeedsProduct -> explain_intro_needs_product ()
- | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp
- | NonLinearProof c -> explain_non_linear_proof c
- | MetaInType c -> explain_meta_in_type c
- | NoSuchHyp id -> explain_no_such_hyp id
-
-(* Inductive errors *)
-
-let error_non_strictly_positive env c v =
- let pc = pr_lconstr_env env Evd.empty c in
- let pv = pr_lconstr_env env Evd.empty v in
- str "Non strictly positive occurrence of " ++ pv ++ str " in" ++
- brk(1,1) ++ pc ++ str "."
-
-let error_ill_formed_inductive env c v =
- let pc = pr_lconstr_env env Evd.empty c in
- let pv = pr_lconstr_env env Evd.empty v in
- str "Not enough arguments applied to the " ++ pv ++
- str " in" ++ brk(1,1) ++ pc ++ str "."
-
-let error_ill_formed_constructor env id c v nparams nargs =
- let pv = pr_lconstr_env env Evd.empty v in
- let atomic = Int.equal (nb_prod c) 0 in
- str "The type of constructor" ++ brk(1,1) ++ pr_id id ++ brk(1,1) ++
- str "is not valid;" ++ brk(1,1) ++
- strbrk (if atomic then "it must be " else "its conclusion must be ") ++
- pv ++
- (* warning: because of implicit arguments it is difficult to say which
- parameters must be explicitly given *)
- (if not (Int.equal nparams 0) then
- strbrk " applied to its " ++ str (String.plural nparams "parameter")
- else
- mt()) ++
- (if not (Int.equal nargs 0) then
- str (if not (Int.equal nparams 0) then " and" else " applied") ++
- strbrk " to some " ++ str (String.plural nargs "argument")
- else
- mt()) ++ str "."
-
-let pr_ltype_using_barendregt_convention_env env c =
- (* Use goal_concl_style as an approximation of Barendregt's convention (?) *)
- quote (pr_goal_concl_style_env env Evd.empty c)
-
-let error_bad_ind_parameters env c n v1 v2 =
- let pc = pr_ltype_using_barendregt_convention_env env c in
- let pv1 = pr_lconstr_env env Evd.empty v1 in
- let pv2 = pr_lconstr_env env Evd.empty v2 in
- str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++
- str " as " ++ pr_nth n ++ str " argument in" ++ brk(1,1) ++ pc ++ str "."
-
-let error_same_names_types id =
- str "The name" ++ spc () ++ pr_id id ++ spc () ++
- str "is used more than once."
-
-let error_same_names_constructors id =
- str "The constructor name" ++ spc () ++ pr_id id ++ spc () ++
- str "is used more than once."
-
-let error_same_names_overlap idl =
- strbrk "The following names are used both as type names and constructor " ++
- str "names:" ++ spc () ++
- prlist_with_sep pr_comma pr_id idl ++ str "."
-
-let error_not_an_arity env c =
- str "The type" ++ spc () ++ pr_lconstr_env env Evd.empty c ++ spc () ++
- str "is not an arity."
-
-let error_bad_entry () =
- str "Bad inductive definition."
-
-let error_large_non_prop_inductive_not_in_type () =
- str "Large non-propositional inductive types must be in Type."
-
-(* Recursion schemes errors *)
-
-let error_not_allowed_case_analysis isrec kind i =
- str (if isrec then "Induction" else "Case analysis") ++
- strbrk " on sort " ++ pr_sort Evd.empty kind ++
- strbrk " is not allowed for inductive definition " ++
- 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") ++
- strbrk " is not allowed for inductive definition " ++
- pr_inductive (Global.env()) i ++ str "."
-
-let error_not_mutual_in_scheme ind ind' =
- if eq_ind ind ind' then
- str "The inductive type " ++ pr_inductive (Global.env()) ind ++
- str " occurs twice."
- else
- str "The inductive types " ++ pr_inductive (Global.env()) ind ++ spc () ++
- str "and" ++ spc () ++ pr_inductive (Global.env()) ind' ++ spc () ++
- str "are not mutually defined."
-
-(* Inductive constructions errors *)
-
-let explain_inductive_error = function
- | NonPos (env,c,v) -> error_non_strictly_positive env c v
- | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive env c v
- | NotConstructor (env,id,c,v,n,m) ->
- error_ill_formed_constructor env id c v n m
- | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters env c n v1 v2
- | SameNamesTypes id -> error_same_names_types id
- | SameNamesConstructors id -> error_same_names_constructors id
- | SameNamesOverlap idl -> error_same_names_overlap idl
- | NotAnArity (env, c) -> error_not_an_arity env c
- | BadEntry -> error_bad_entry ()
- | LargeNonPropInductiveNotInType ->
- error_large_non_prop_inductive_not_in_type ()
-
-(* Recursion schemes errors *)
-
-let explain_recursion_scheme_error = function
- | NotAllowedCaseAnalysis (isrec,k,i) ->
- error_not_allowed_case_analysis isrec k i
- | NotMutualInScheme (ind,ind')-> error_not_mutual_in_scheme ind ind'
- | NotAllowedDependentAnalysis (isrec, i) ->
- error_not_allowed_dependent_analysis isrec i
-
-(* Pattern-matching errors *)
-
-let explain_bad_pattern env sigma cstr ty =
- let env = make_all_name_different env in
- let pt = pr_lconstr_env env sigma ty in
- let pc = pr_constructor env cstr in
- str "Found the constructor " ++ pc ++ brk(1,1) ++
- str "while matching a term of type " ++ pt ++ brk(1,1) ++
- str "which is not an inductive type."
-
-let explain_bad_constructor env cstr ind =
- let pi = pr_inductive env ind in
-(* let pc = pr_constructor env cstr in*)
- let pt = pr_inductive env (inductive_of_constructor cstr) in
- str "Found a constructor of inductive type " ++ pt ++ brk(1,1) ++
- str "while a constructor of " ++ pi ++ brk(1,1) ++
- str "is expected."
-
-let decline_string n s =
- if Int.equal n 0 then str "no " ++ str s ++ str "s"
- else if Int.equal n 1 then str "1 " ++ str s
- else (int n ++ str " " ++ str s ++ str "s")
-
-let explain_wrong_numarg_constructor env cstr n =
- str "The constructor " ++ pr_constructor env cstr ++
- str " (in type " ++ pr_inductive env (inductive_of_constructor cstr) ++
- str ") expects " ++ decline_string n "argument" ++ str "."
-
-let explain_wrong_numarg_inductive env ind n =
- str "The inductive type " ++ pr_inductive env ind ++
- str " expects " ++ decline_string n "argument" ++ str "."
-
-let explain_unused_clause env pats =
-(* Without localisation
- let s = if List.length pats > 1 then "s" else "" in
- (str ("Unused clause with pattern"^s) ++ spc () ++
- hov 0 (pr_sequence pr_cases_pattern pats) ++ str ")")
-*)
- str "This clause is redundant."
-
-let explain_non_exhaustive env pats =
- str "Non exhaustive pattern-matching: no clause found for " ++
- str (String.plural (List.length pats) "pattern") ++
- spc () ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats)
-
-let explain_cannot_infer_predicate env sigma typs =
- let env = make_all_name_different env in
- let pr_branch (cstr,typ) =
- let cstr,_ = decompose_app cstr in
- str "For " ++ pr_lconstr_env env sigma cstr ++ str ": " ++ pr_lconstr_env env sigma typ
- in
- str "Unable to unify the types found in the branches:" ++
- spc () ++ hov 0 (prlist_with_sep fnl pr_branch (Array.to_list typs))
-
-let explain_pattern_matching_error env sigma = function
- | BadPattern (c,t) ->
- explain_bad_pattern env sigma c t
- | BadConstructor (c,ind) ->
- explain_bad_constructor env c ind
- | WrongNumargConstructor (c,n) ->
- explain_wrong_numarg_constructor env c n
- | WrongNumargInductive (c,n) ->
- explain_wrong_numarg_inductive env c n
- | UnusedClause tms ->
- explain_unused_clause env tms
- | NonExhaustive tms ->
- explain_non_exhaustive env tms
- | CannotInferPredicate typs ->
- explain_cannot_infer_predicate env sigma typs
-
-let explain_reduction_tactic_error = function
- | Tacred.InvalidAbstraction (env,sigma,c,(env',e)) ->
- str "The abstracted term" ++ spc () ++
- quote (pr_goal_concl_style_env env sigma c) ++
- spc () ++ str "is not well typed." ++ fnl () ++
- explain_type_error env' Evd.empty e
diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli
deleted file mode 100644
index ced54fd2..00000000
--- a/toplevel/himsg.mli
+++ /dev/null
@@ -1,42 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Indtypes
-open Environ
-open Type_errors
-open Pretype_errors
-open Typeclasses_errors
-open Indrec
-open Cases
-open Logic
-
-(** This module provides functions to explain the type errors. *)
-
-val explain_type_error : env -> Evd.evar_map -> type_error -> std_ppcmds
-
-val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> std_ppcmds
-
-val explain_inductive_error : inductive_error -> std_ppcmds
-
-val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds
-
-val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds
-
-val explain_refiner_error : refiner_error -> std_ppcmds
-
-val explain_pattern_matching_error :
- env -> Evd.evar_map -> pattern_matching_error -> std_ppcmds
-
-val explain_reduction_tactic_error :
- Tacred.reduction_tactic_error -> std_ppcmds
-
-val explain_module_error : Modops.module_typing_error -> std_ppcmds
-
-val explain_module_internalization_error :
- Modintern.module_internalization_error -> std_ppcmds
diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml
deleted file mode 100644
index 6d57a21d..00000000
--- a/toplevel/ind_tables.ml
+++ /dev/null
@@ -1,203 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* File created by Vincent Siles, Oct 2007, extended into a generic
- support for generation of inductive schemes by Hugo Herbelin, Nov 2009 *)
-
-(* This file provides support for registering inductive scheme builders,
- declaring schemes and generating schemes on demand *)
-
-open Names
-open Mod_subst
-open Libobject
-open Nameops
-open Declarations
-open Term
-open CErrors
-open Util
-open Declare
-open Entries
-open Decl_kinds
-open Pp
-
-(**********************************************************************)
-(* Registering schemes in the environment *)
-
-type mutual_scheme_object_function =
- internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants
-type individual_scheme_object_function =
- internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants
-
-type 'a scheme_kind = string
-
-let scheme_map = Summary.ref Indmap.empty ~name:"Schemes"
-
-let pr_scheme_kind = Pp.str
-
-let cache_one_scheme kind (ind,const) =
- let map = try Indmap.find ind !scheme_map with Not_found -> String.Map.empty in
- scheme_map := Indmap.add ind (String.Map.add kind const map) !scheme_map
-
-let cache_scheme (_,(kind,l)) =
- Array.iter (cache_one_scheme kind) l
-
-let subst_one_scheme subst (ind,const) =
- (* Remark: const is a def: the result of substitution is a constant *)
- (subst_ind subst ind,subst_constant subst const)
-
-let subst_scheme (subst,(kind,l)) =
- (kind,Array.map (subst_one_scheme subst) l)
-
-let discharge_scheme (_,(kind,l)) =
- Some (kind,Array.map (fun (ind,const) ->
- (Lib.discharge_inductive ind,Lib.discharge_con const)) l)
-
-let inScheme : string * (inductive * constant) array -> obj =
- declare_object {(default_object "SCHEME") with
- cache_function = cache_scheme;
- load_function = (fun _ -> cache_scheme);
- subst_function = subst_scheme;
- classify_function = (fun obj -> Substitute obj);
- discharge_function = discharge_scheme}
-
-(**********************************************************************)
-(* The table of scheme building functions *)
-
-type individual
-type mutual
-
-type scheme_object_function =
- | MutualSchemeFunction of mutual_scheme_object_function
- | IndividualSchemeFunction of individual_scheme_object_function
-
-let scheme_object_table =
- (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t)
-
-let declare_scheme_object s aux f =
- let () =
- if not (Id.is_valid ("ind" ^ s)) then
- error ("Illegal induction scheme suffix: " ^ s)
- in
- let key = if String.is_empty aux then s else aux in
- try
- let _ = Hashtbl.find scheme_object_table key in
-(* let aux_msg = if aux="" then "" else " (with key "^aux^")" in*)
- errorlabstrm "IndTables.declare_scheme_object"
- (str "Scheme object " ++ str key ++ str " already declared.")
- with Not_found ->
- Hashtbl.add scheme_object_table key (s,f);
- key
-
-let declare_mutual_scheme_object s ?(aux="") f =
- declare_scheme_object s aux (MutualSchemeFunction f)
-
-let declare_individual_scheme_object s ?(aux="") f =
- declare_scheme_object s aux (IndividualSchemeFunction f)
-
-(**********************************************************************)
-(* Defining/retrieving schemes *)
-
-let declare_scheme kind indcl =
- Lib.add_anonymous_leaf (inScheme (kind,indcl))
-
-let () = Declare.set_declare_scheme declare_scheme
-
-let is_visible_name id =
- try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true
- with Not_found -> false
-
-let compute_name internal id =
- match internal with
- | UserAutomaticRequest | UserIndividualRequest -> id
- | InternalTacticRequest ->
- Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name
-
-let define internal id c p univs =
- let fd = declare_constant ~internal in
- let id = compute_name internal id in
- let ctx = Evd.normalize_evar_universe_context univs in
- let c = Vars.subst_univs_fn_constr
- (Universes.make_opt_subst (Evd.evar_universe_context_subst ctx)) c in
- let entry = {
- const_entry_body =
- Future.from_val ((c,Univ.ContextSet.empty),
- Safe_typing.empty_private_constants);
- const_entry_secctx = None;
- const_entry_type = None;
- const_entry_polymorphic = p;
- const_entry_universes = Evd.evar_context_universe_context ctx;
- const_entry_opaque = false;
- const_entry_inline_code = false;
- const_entry_feedback = None;
- } in
- let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in
- let () = match internal with
- | InternalTacticRequest -> ()
- | _-> definition_message id
- in
- kn
-
-let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) =
- let (c, ctx), eff = f mode ind in
- let mib = Global.lookup_mind mind in
- let id = match idopt with
- | Some id -> id
- | None -> add_suffix mib.mind_packets.(i).mind_typename suff in
- let const = define mode id c mib.mind_polymorphic ctx in
- declare_scheme kind [|ind,const|];
- const, Safe_typing.add_private
- (Safe_typing.private_con_of_scheme kind (Global.safe_env()) [ind,const]) eff
-
-let define_individual_scheme kind mode names (mind,i as ind) =
- match Hashtbl.find scheme_object_table kind with
- | _,MutualSchemeFunction f -> assert false
- | s,IndividualSchemeFunction f ->
- define_individual_scheme_base kind s f mode names ind
-
-let define_mutual_scheme_base kind suff f mode names mind =
- let (cl, ctx), eff = f mode mind in
- let mib = Global.lookup_mind mind in
- let ids = Array.init (Array.length mib.mind_packets) (fun i ->
- try Int.List.assoc i names
- with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in
- let consts = Array.map2 (fun id cl ->
- define mode id cl mib.mind_polymorphic ctx) ids cl in
- let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in
- declare_scheme kind schemes;
- consts,
- Safe_typing.add_private
- (Safe_typing.private_con_of_scheme
- kind (Global.safe_env()) (Array.to_list schemes))
- eff
-
-let define_mutual_scheme kind mode names mind =
- match Hashtbl.find scheme_object_table kind with
- | _,IndividualSchemeFunction _ -> assert false
- | s,MutualSchemeFunction f ->
- define_mutual_scheme_base kind s f mode names mind
-
-let find_scheme_on_env_too kind ind =
- let s = String.Map.find kind (Indmap.find ind !scheme_map) in
- s, Safe_typing.add_private
- (Safe_typing.private_con_of_scheme
- kind (Global.safe_env()) [ind, s])
- Safe_typing.empty_private_constants
-
-let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) =
- try find_scheme_on_env_too kind ind
- with Not_found ->
- match Hashtbl.find scheme_object_table kind with
- | s,IndividualSchemeFunction f ->
- define_individual_scheme_base kind s f mode None ind
- | s,MutualSchemeFunction f ->
- let ca, eff = define_mutual_scheme_base kind s f mode [] mind in
- ca.(i), eff
-
-let check_scheme kind ind =
- try let _ = find_scheme_on_env_too kind ind in true
- with Not_found -> false
diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli
deleted file mode 100644
index 20f30d6d..00000000
--- a/toplevel/ind_tables.mli
+++ /dev/null
@@ -1,51 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Term
-open Names
-open Declare
-
-(** This module provides support for registering inductive scheme builders,
- declaring schemes and generating schemes on demand *)
-
-(** A scheme is either a "mutual scheme_kind" or an "individual scheme_kind" *)
-
-type mutual
-type individual
-type 'a scheme_kind
-
-type mutual_scheme_object_function =
- internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants
-type individual_scheme_object_function =
- internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants
-
-(** Main functions to register a scheme builder *)
-
-val declare_mutual_scheme_object : string -> ?aux:string ->
- mutual_scheme_object_function -> mutual scheme_kind
-
-val declare_individual_scheme_object : string -> ?aux:string ->
- individual_scheme_object_function ->
- individual scheme_kind
-
-(** Force generation of a (mutually) scheme with possibly user-level names *)
-
-val define_individual_scheme : individual scheme_kind ->
- internal_flag (** internal *) ->
- Id.t option -> inductive -> constant * Safe_typing.private_constants
-
-val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) ->
- (int * Id.t) list -> mutual_inductive -> constant array * Safe_typing.private_constants
-
-(** Main function to retrieve a scheme in the cache or to generate it *)
-val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> constant * Safe_typing.private_constants
-
-val check_scheme : 'a scheme_kind -> inductive -> bool
-
-
-val pr_scheme_kind : 'a scheme_kind -> Pp.std_ppcmds
diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml
deleted file mode 100644
index e8ea617f..00000000
--- a/toplevel/indschemes.ml
+++ /dev/null
@@ -1,524 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* Created by Hugo Herbelin from contents related to inductive schemes
- initially developed by Christine Paulin (induction schemes), Vincent
- Siles (decidable equality and boolean equality) and Matthieu Sozeau
- (combined scheme) in file command.ml, Sep 2009 *)
-
-(* This file provides entry points for manually or automatically
- declaring new schemes *)
-
-open Pp
-open CErrors
-open Util
-open Names
-open Declarations
-open Entries
-open Term
-open Inductive
-open Decl_kinds
-open Indrec
-open Declare
-open Libnames
-open Globnames
-open Goptions
-open Nameops
-open Termops
-open Pretyping
-open Nametab
-open Smartlocate
-open Vernacexpr
-open Ind_tables
-open Auto_ind_decl
-open Eqschemes
-open Elimschemes
-open Context.Rel.Declaration
-
-(* Flags governing automatic synthesis of schemes *)
-
-let elim_flag = ref true
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "automatic declaration of induction schemes";
- optkey = ["Elimination";"Schemes"];
- optread = (fun () -> !elim_flag) ;
- optwrite = (fun b -> elim_flag := b) }
-
-let bifinite_elim_flag = ref false
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "automatic declaration of induction schemes for non-recursive types";
- optkey = ["Nonrecursive";"Elimination";"Schemes"];
- optread = (fun () -> !bifinite_elim_flag) ;
- optwrite = (fun b -> bifinite_elim_flag := b) }
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = true; (* compatibility 2014-09-03*)
- optname = "automatic declaration of induction schemes for non-recursive types";
- optkey = ["Record";"Elimination";"Schemes"];
- optread = (fun () -> !bifinite_elim_flag) ;
- optwrite = (fun b -> bifinite_elim_flag := b) }
-
-let case_flag = ref false
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "automatic declaration of case analysis schemes";
- optkey = ["Case";"Analysis";"Schemes"];
- optread = (fun () -> !case_flag) ;
- optwrite = (fun b -> case_flag := b) }
-
-let eq_flag = ref false
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "automatic declaration of boolean equality";
- optkey = ["Boolean";"Equality";"Schemes"];
- optread = (fun () -> !eq_flag) ;
- optwrite = (fun b -> eq_flag := b) }
-let _ = (* compatibility *)
- declare_bool_option
- { optsync = true;
- optdepr = true;
- optname = "automatic declaration of boolean equality";
- optkey = ["Equality";"Scheme"];
- optread = (fun () -> !eq_flag) ;
- optwrite = (fun b -> eq_flag := b) }
-
-let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2
-
-let eq_dec_flag = ref false
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "automatic declaration of decidable equality";
- optkey = ["Decidable";"Equality";"Schemes"];
- optread = (fun () -> !eq_dec_flag) ;
- optwrite = (fun b -> eq_dec_flag := b) }
-
-let rewriting_flag = ref false
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname ="automatic declaration of rewriting schemes for equality types";
- optkey = ["Rewriting";"Schemes"];
- optread = (fun () -> !rewriting_flag) ;
- optwrite = (fun b -> rewriting_flag := b) }
-
-(* Util *)
-
-let define id internal ctx c t =
- let f = declare_constant ~internal in
- let kn = f id
- (DefinitionEntry
- { const_entry_body = c;
- const_entry_secctx = None;
- const_entry_type = t;
- const_entry_polymorphic = Flags.is_universe_polymorphism ();
- const_entry_universes = snd (Evd.universe_context ctx);
- const_entry_opaque = false;
- const_entry_inline_code = false;
- const_entry_feedback = None;
- },
- Decl_kinds.IsDefinition Scheme) in
- definition_message id;
- kn
-
-(* Boolean equality *)
-
-let declare_beq_scheme_gen internal names kn =
- ignore (define_mutual_scheme beq_scheme_kind internal names kn)
-
-let alarm what internal msg =
- let debug = false in
- match internal with
- | UserAutomaticRequest
- | InternalTacticRequest ->
- (if debug then
- Feedback.msg_debug
- (hov 0 msg ++ fnl () ++ what ++ str " not defined.")); None
- | _ -> Some msg
-
-let try_declare_scheme what f internal names kn =
- try f internal names kn
- with e ->
- let e = CErrors.push e in
- let msg = match fst e with
- | ParameterWithoutEquality cst ->
- alarm what internal
- (str "Boolean equality not found for parameter " ++ Printer.pr_global cst ++
- str".")
- | InductiveWithProduct ->
- alarm what internal
- (str "Unable to decide equality of functional arguments.")
- | InductiveWithSort ->
- alarm what internal
- (str "Unable to decide equality of type arguments.")
- | NonSingletonProp ind ->
- alarm what internal
- (str "Cannot extract computational content from proposition " ++
- quote (Printer.pr_inductive (Global.env()) ind) ++ str ".")
- | EqNotFound (ind',ind) ->
- alarm what internal
- (str "Boolean equality on " ++
- quote (Printer.pr_inductive (Global.env()) ind') ++
- strbrk " is missing.")
- | UndefinedCst s ->
- alarm what internal
- (strbrk "Required constant " ++ str s ++ str " undefined.")
- | AlreadyDeclared msg ->
- alarm what internal (msg ++ str ".")
- | DecidabilityMutualNotSupported ->
- alarm what internal
- (str "Decidability lemma for mutual inductive types not supported.")
- | e when CErrors.noncritical e ->
- alarm what internal
- (str "Unexpected error during scheme creation: " ++ CErrors.print e)
- | _ -> iraise e
- in
- match msg with
- | None -> ()
- | Some msg -> iraise (UserError ("", msg), snd e)
-
-let beq_scheme_msg mind =
- let mib = Global.lookup_mind mind in
- (* TODO: mutual inductive case *)
- str "Boolean equality on " ++
- pr_enum (fun ind -> quote (Printer.pr_inductive (Global.env()) ind))
- (List.init (Array.length mib.mind_packets) (fun i -> (mind,i)))
-
-let declare_beq_scheme_with l kn =
- try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserIndividualRequest l kn
-
-let try_declare_beq_scheme kn =
- (* TODO: handle Fix, eventually handle
- proof-irrelevance; improve decidability by depending on decidability
- for the parameters rather than on the bl and lb properties *)
- try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserAutomaticRequest [] kn
-
-let declare_beq_scheme = declare_beq_scheme_with []
-
-(* Case analysis schemes *)
-let declare_one_case_analysis_scheme ind =
- let (mib,mip) = Global.lookup_inductive ind in
- let kind = inductive_sort_family mip in
- let dep =
- if kind == InProp then case_scheme_kind_from_prop
- else if not (Inductiveops.has_dependent_elim mib) then
- case_scheme_kind_from_type
- else case_dep_scheme_kind_from_type in
- let kelim = elim_sorts (mib,mip) in
- (* in case the inductive has a type elimination, generates only one
- induction scheme, the other ones share the same code with the
- apropriate type *)
- if Sorts.List.mem InType kelim then
- ignore (define_individual_scheme dep UserAutomaticRequest None ind)
-
-(* Induction/recursion schemes *)
-
-let kinds_from_prop =
- [InType,rect_scheme_kind_from_prop;
- InProp,ind_scheme_kind_from_prop;
- InSet,rec_scheme_kind_from_prop]
-
-let kinds_from_type =
- [InType,rect_dep_scheme_kind_from_type;
- InProp,ind_dep_scheme_kind_from_type;
- InSet,rec_dep_scheme_kind_from_type]
-
-let nondep_kinds_from_type =
- [InType,rect_scheme_kind_from_type;
- InProp,ind_scheme_kind_from_type;
- InSet,rec_scheme_kind_from_type]
-
-let declare_one_induction_scheme ind =
- let (mib,mip) = Global.lookup_inductive ind in
- let kind = inductive_sort_family mip in
- let from_prop = kind == InProp in
- let depelim = Inductiveops.has_dependent_elim mib in
- let kelim = elim_sorts (mib,mip) in
- let elims =
- List.map_filter (fun (sort,kind) ->
- if Sorts.List.mem sort kelim then Some kind else None)
- (if from_prop then kinds_from_prop
- else if depelim then kinds_from_type
- else nondep_kinds_from_type) in
- List.iter (fun kind -> ignore (define_individual_scheme kind UserAutomaticRequest None ind))
- elims
-
-let declare_induction_schemes kn =
- let mib = Global.lookup_mind kn in
- if mib.mind_finite <> Decl_kinds.CoFinite then begin
- for i = 0 to Array.length mib.mind_packets - 1 do
- declare_one_induction_scheme (kn,i);
- done;
- end
-
-(* Decidable equality *)
-
-let declare_eq_decidability_gen internal names kn =
- let mib = Global.lookup_mind kn in
- if mib.mind_finite <> Decl_kinds.CoFinite then
- ignore (define_mutual_scheme eq_dec_scheme_kind internal names kn)
-
-let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *)
- str "Decidable equality on " ++ quote (Printer.pr_inductive (Global.env()) ind)
-
-let declare_eq_decidability_scheme_with l kn =
- try_declare_scheme (eq_dec_scheme_msg (kn,0))
- declare_eq_decidability_gen UserIndividualRequest l kn
-
-let try_declare_eq_decidability kn =
- try_declare_scheme (eq_dec_scheme_msg (kn,0))
- declare_eq_decidability_gen UserAutomaticRequest [] kn
-
-let declare_eq_decidability = declare_eq_decidability_scheme_with []
-
-let ignore_error f x =
- try ignore (f x) with e when CErrors.noncritical e -> ()
-
-let declare_rewriting_schemes ind =
- if Hipattern.is_inductive_equality ind then begin
- ignore (define_individual_scheme rew_r2l_scheme_kind UserAutomaticRequest None ind);
- ignore (define_individual_scheme rew_r2l_dep_scheme_kind UserAutomaticRequest None ind);
- ignore (define_individual_scheme rew_r2l_forward_dep_scheme_kind
- UserAutomaticRequest None ind);
- (* These ones expect the equality to be symmetric; the first one also *)
- (* needs eq *)
- ignore_error (define_individual_scheme rew_l2r_scheme_kind UserAutomaticRequest None) ind;
- ignore_error
- (define_individual_scheme rew_l2r_dep_scheme_kind UserAutomaticRequest None) ind;
- ignore_error
- (define_individual_scheme rew_l2r_forward_dep_scheme_kind UserAutomaticRequest None) ind
- end
-
-let warn_cannot_build_congruence =
- CWarnings.create ~name:"cannot-build-congruence" ~category:"schemes"
- (fun () ->
- strbrk "Cannot build congruence scheme because eq is not found")
-
-let declare_congr_scheme ind =
- if Hipattern.is_equality_type (mkInd ind) then begin
- if
- try Coqlib.check_required_library Coqlib.logic_module_name; true
- with e when CErrors.noncritical e -> false
- then
- ignore (define_individual_scheme congr_scheme_kind UserAutomaticRequest None ind)
- else
- warn_cannot_build_congruence ()
- end
-
-let declare_sym_scheme ind =
- if Hipattern.is_inductive_equality ind then
- (* Expect the equality to be symmetric *)
- ignore_error (define_individual_scheme sym_scheme_kind UserAutomaticRequest None) ind
-
-(* Scheme command *)
-
-let smart_global_inductive y = smart_global_inductive y
-let rec split_scheme l =
- let env = Global.env() in
- match l with
- | [] -> [],[]
- | (Some id,t)::q -> let l1,l2 = split_scheme q in
- ( match t with
- | InductionScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2
- | CaseScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2
- | EqualityScheme x -> l1,((Some id,smart_global_inductive x)::l2)
- )
-(*
- if no name has been provided, we build one from the types of the ind
-requested
-*)
- | (None,t)::q ->
- let l1,l2 = split_scheme q in
- 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
- | InProp -> inds ^ "_dep"
- | InSet -> recs ^ "_dep"
- | InType -> recs ^ "t_dep")
- else ( match z' with
- | InProp -> inds
- | InSet -> recs
- | InType -> recs ^ "t" )
- | _ ->
- if isdep then (match z' with
- | InProp -> inds
- | InSet -> recs
- | InType -> recs ^ "t" )
- else (match z' with
- | InProp -> inds ^ "_nodep"
- | InSet -> recs ^ "_nodep"
- | InType -> recs ^ "t_nodep")
- ) in
- let newid = add_suffix (basename_of_global (IndRef ind)) suffix in
- let newref = (Loc.ghost,newid) in
- ((newref,isdep,ind,z)::l1),l2
- in
- match t with
- | CaseScheme (x,y,z) -> names "_case" "_case" x y z
- | InductionScheme (x,y,z) -> names "_ind" "_rec" x y z
- | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2)
-
-
-let do_mutual_induction_scheme lnamedepindsort =
- let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort
- and env0 = Global.env() in
- let sigma, lrecspec, _ =
- List.fold_right
- (fun (_,dep,ind,sort) (evd, l, inst) ->
- let evd, indu, inst =
- match inst with
- | None ->
- let _, ctx = Global.type_of_global_in_context env0 (IndRef ind) in
- let ctxs = Univ.ContextSet.of_context ctx in
- let evd = Evd.from_ctx (Evd.evar_universe_context_of ctxs) in
- let u = Univ.UContext.instance ctx in
- evd, (ind,u), Some u
- | Some ui -> evd, (ind, ui), inst
- in
- (evd, (indu,dep,interp_elimination_sort sort) :: l, inst))
- lnamedepindsort (Evd.from_env env0,[],None)
- in
- let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in
- let declare decl fi lrecref =
- let decltype = Retyping.get_type_of env0 sigma decl in
- let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in
- let cst = define fi UserIndividualRequest sigma proof_output (Some decltype) in
- ConstRef cst :: lrecref
- in
- let _ = List.fold_right2 declare listdecl lrecnames [] in
- fixpoint_message None lrecnames
-
-let get_common_underlying_mutual_inductive = function
- | [] -> assert false
- | (id,(mind,i as ind))::l as all ->
- match List.filter (fun (_,(mind',_)) -> not (eq_mind mind mind')) l with
- | (_,ind')::_ ->
- raise (RecursionSchemeError (NotMutualInScheme (ind,ind')))
- | [] ->
- if not (List.distinct_f Int.compare (List.map snd (List.map snd all)))
- then error "A type occurs twice";
- mind,
- List.map_filter
- (function (Some id,(_,i)) -> Some (i,snd id) | (None,_) -> None) all
-
-let do_scheme l =
- let ischeme,escheme = split_scheme l in
-(* we want 1 kind of scheme at a time so we check if the user
-tried to declare different schemes at once *)
- if not (List.is_empty ischeme) && not (List.is_empty escheme)
- then
- error "Do not declare equality and induction scheme at the same time."
- else (
- if not (List.is_empty ischeme) then do_mutual_induction_scheme ischeme
- else
- let mind,l = get_common_underlying_mutual_inductive escheme in
- declare_beq_scheme_with l mind;
- declare_eq_decidability_scheme_with l mind
- )
-
-(**********************************************************************)
-(* Combined scheme *)
-(* Matthieu Sozeau, Dec 2006 *)
-
-let list_split_rev_at index l =
- let rec aux i acc = function
- hd :: tl when Int.equal i index -> acc, tl
- | hd :: tl -> aux (succ i) (hd :: acc) tl
- | [] -> failwith "List.split_when: Invalid argument"
- in aux 0 [] l
-
-let fold_left' f = function
- [] -> invalid_arg "fold_left'"
- | hd :: tl -> List.fold_left f hd tl
-
-let build_combined_scheme env schemes =
- let defs = List.map (fun cst -> (* FIXME *)
- let evd, c = Evd.fresh_constant_instance env (Evd.from_env env) cst in
- (c, Typeops.type_of_constant_in env c)) schemes in
-(* let nschemes = List.length schemes in *)
- let find_inductive ty =
- let (ctx, arity) = decompose_prod ty in
- let (_, last) = List.hd ctx in
- match kind_of_term last with
- | App (ind, args) ->
- let ind = destInd ind in
- let (_,spec) = Inductive.lookup_mind_specif env (fst ind) in
- ctx, ind, spec.mind_nrealargs
- | _ -> ctx, destInd last, 0
- in
- let (c, t) = List.hd defs in
- let ctx, ind, nargs = find_inductive t in
- (* Number of clauses, including the predicates quantification *)
- let prods = nb_prod t - (nargs + 1) in
- let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in
- let relargs = rel_vect 0 prods in
- let concls = List.rev_map
- (fun (cst, t) -> (* FIXME *)
- mkApp(mkConstU cst, relargs),
- snd (decompose_prod_n prods t)) defs in
- let concl_bod, concl_typ =
- fold_left'
- (fun (accb, acct) (cst, x) ->
- mkApp (coqconj, [| x; acct; cst; accb |]),
- mkApp (coqand, [| x; acct |])) concls
- in
- let ctx, _ =
- list_split_rev_at prods
- (List.rev_map (fun (x, y) -> LocalAssum (x, y)) ctx) in
- let typ = it_mkProd_wo_LetIn concl_typ ctx in
- let body = it_mkLambda_or_LetIn concl_bod ctx in
- (body, typ)
-
-let do_combined_scheme name schemes =
- let csts =
- List.map (fun x ->
- let refe = Ident x in
- let qualid = qualid_of_reference refe in
- try Nametab.locate_constant (snd qualid)
- with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared."))
- schemes
- in
- let body,typ = build_combined_scheme (Global.env ()) csts in
- let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in
- ignore (define (snd name) UserIndividualRequest Evd.empty proof_output (Some typ));
- fixpoint_message None [snd name]
-
-(**********************************************************************)
-
-let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done
-
-let declare_default_schemes kn =
- let mib = Global.lookup_mind kn in
- let n = Array.length mib.mind_packets in
- if !elim_flag && (mib.mind_finite <> BiFinite || !bifinite_elim_flag)
- && mib.mind_typing_flags.check_guarded then
- declare_induction_schemes kn;
- if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n;
- if is_eq_flag() then try_declare_beq_scheme kn;
- if !eq_dec_flag then try_declare_eq_decidability kn;
- if !rewriting_flag then map_inductive_block declare_congr_scheme kn n;
- if !rewriting_flag then map_inductive_block declare_sym_scheme kn n;
- if !rewriting_flag then map_inductive_block declare_rewriting_schemes kn n
diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli
deleted file mode 100644
index e5d79fd5..00000000
--- a/toplevel/indschemes.mli
+++ /dev/null
@@ -1,49 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Loc
-open Names
-open Term
-open Environ
-open Vernacexpr
-open Misctypes
-
-(** See also Auto_ind_decl, Indrec, Eqscheme, Ind_tables, ... *)
-
-(** Build and register the boolean equalities associated to an inductive type *)
-
-val declare_beq_scheme : mutual_inductive -> unit
-
-val declare_eq_decidability : mutual_inductive -> unit
-
-(** Build and register a congruence scheme for an equality-like inductive type *)
-
-val declare_congr_scheme : inductive -> unit
-
-(** Build and register rewriting schemes for an equality-like inductive type *)
-
-val declare_rewriting_schemes : inductive -> unit
-
-(** Mutual Minimality/Induction scheme *)
-
-val do_mutual_induction_scheme :
- (Id.t located * bool * inductive * glob_sort) list -> unit
-
-(** Main calls to interpret the Scheme command *)
-
-val do_scheme : (Id.t located option * scheme) list -> unit
-
-(** Combine a list of schemes into a conjunction of them *)
-
-val build_combined_scheme : env -> constant list -> constr * types
-
-val do_combined_scheme : Id.t located -> Id.t located list -> unit
-
-(** Hook called at each inductive type definition *)
-
-val declare_default_schemes : mutual_inductive -> unit
diff --git a/toplevel/locality.ml b/toplevel/locality.ml
deleted file mode 100644
index 154f787e..00000000
--- a/toplevel/locality.ml
+++ /dev/null
@@ -1,107 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-
-(** * Managing locality *)
-
-let local_of_bool = function
- | true -> Decl_kinds.Local
- | false -> Decl_kinds.Global
-
-let check_locality locality_flag =
- match locality_flag with
- | Some b ->
- let s = if b then "Local" else "Global" in
- CErrors.errorlabstrm "Locality.check_locality"
- (str "This command does not support the \"" ++ str s ++ str "\" prefix.")
- | None -> ()
-
-(** Extracting the locality flag *)
-
-(* Commands which supported an inlined Local flag *)
-
-let warn_deprecated_local_syntax =
- CWarnings.create ~name:"deprecated-local-syntax" ~category:"deprecated"
- (fun () ->
- Pp.strbrk "Deprecated syntax: use \"Local\" as a prefix.")
-
-let enforce_locality_full locality_flag local =
- let local =
- match locality_flag with
- | Some false when local ->
- CErrors.error "Cannot be simultaneously Local and Global."
- | Some true when local ->
- CErrors.error "Use only prefix \"Local\"."
- | None ->
- if local then begin
- warn_deprecated_local_syntax ();
- Some true
- end else
- None
- | Some b -> Some b in
- local
-
-(** Positioning locality for commands supporting discharging and export
- outside of modules *)
-
-(* For commands whose default is to discharge and export:
- Global is the default and is neutral;
- Local in a section deactivates discharge,
- Local not in a section deactivates export *)
-let make_non_locality = function Some false -> false | _ -> true
-
-let make_locality = function Some true -> true | _ -> false
-
-let enforce_locality locality_flag local =
- make_locality (enforce_locality_full locality_flag local)
-
-let enforce_locality_exp locality_flag local =
- match locality_flag, local with
- | None, Some local -> local
- | Some b, None -> local_of_bool b
- | None, None -> Decl_kinds.Global
- | Some _, Some _ -> CErrors.error "Local non allowed in this case"
-
-(* For commands whose default is to not discharge but to export:
- Global in sections forces discharge, Global not in section is the default;
- Local in sections is the default, Local not in section forces non-export *)
-
-let make_section_locality =
- function Some b -> b | None -> Lib.sections_are_opened ()
-
-let enforce_section_locality locality_flag local =
- make_section_locality (enforce_locality_full locality_flag local)
-
-(** Positioning locality for commands supporting export but not discharge *)
-
-(* For commands whose default is to export (if not in section):
- Global in sections is forbidden, Global not in section is neutral;
- Local in sections is the default, Local not in section forces non-export *)
-
-let make_module_locality = function
- | Some false ->
- if Lib.sections_are_opened () then
- CErrors.error
- "This command does not support the Global option in sections.";
- false
- | Some true -> true
- | None -> false
-
-let enforce_module_locality locality_flag local =
- make_module_locality (enforce_locality_full locality_flag local)
-
-module LocalityFixme = struct
- let locality = ref None
- let set l = locality := l
- let consume () =
- let l = !locality in
- locality := None;
- l
- let assert_consumed () = check_locality !locality
-end
diff --git a/toplevel/locality.mli b/toplevel/locality.mli
deleted file mode 100644
index 2ec392ee..00000000
--- a/toplevel/locality.mli
+++ /dev/null
@@ -1,51 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(** * Managing locality *)
-
-(** Commands which supported an inlined Local flag *)
-
-val enforce_locality_full : bool option -> bool -> bool option
-
-(** * Positioning locality for commands supporting discharging and export
- outside of modules *)
-
-(** For commands whose default is to discharge and export:
- Global is the default and is neutral;
- Local in a section deactivates discharge,
- Local not in a section deactivates export *)
-
-val make_locality : bool option -> bool
-val make_non_locality : bool option -> bool
-val enforce_locality : bool option -> bool -> bool
-val enforce_locality_exp :
- bool option -> Decl_kinds.locality option -> Decl_kinds.locality
-
-(** For commands whose default is to not discharge but to export:
- Global in sections forces discharge, Global not in section is the default;
- Local in sections is the default, Local not in section forces non-export *)
-
-val make_section_locality : bool option -> bool
-val enforce_section_locality : bool option -> bool -> bool
-
-(** * Positioning locality for commands supporting export but not discharge *)
-
-(** For commands whose default is to export (if not in section):
- Global in sections is forbidden, Global not in section is neutral;
- Local in sections is the default, Local not in section forces non-export *)
-
-val make_module_locality : bool option -> bool
-val enforce_module_locality : bool option -> bool -> bool
-
-(* This is the old imperative interface that is still used for
- * VernacExtend vernaculars. Time permitting this could be trashed too *)
-module LocalityFixme : sig
- val set : bool option -> unit
- val consume : unit -> bool option
- val assert_consumed : unit -> unit
-end
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
deleted file mode 100644
index 008d5cf9..00000000
--- a/toplevel/metasyntax.ml
+++ /dev/null
@@ -1,1379 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Flags
-open CErrors
-open Util
-open Names
-open Constrexpr
-open Constrexpr_ops
-open Notation_term
-open Notation_ops
-open Ppextend
-open Extend
-open Libobject
-open Constrintern
-open Vernacexpr
-open Pcoq
-open Libnames
-open Tok
-open Egramcoq
-open Notation
-open Nameops
-
-(**********************************************************************)
-(* Tokens *)
-
-let cache_token (_,s) = CLexer.add_keyword s
-
-let inToken : string -> obj =
- declare_object {(default_object "TOKEN") with
- open_function = (fun i o -> if Int.equal i 1 then cache_token o);
- cache_function = cache_token;
- subst_function = Libobject.ident_subst_function;
- classify_function = (fun o -> Substitute o)}
-
-let add_token_obj s = Lib.add_anonymous_leaf (inToken s)
-
-(**********************************************************************)
-(* Printing grammar entries *)
-
-let entry_buf = Buffer.create 64
-
-let pr_entry e =
- let () = Buffer.clear entry_buf in
- let ft = Format.formatter_of_buffer entry_buf in
- let () = Gram.entry_print ft e in
- str (Buffer.contents entry_buf)
-
-let pr_grammar = function
- | "constr" | "operconstr" | "binder_constr" ->
- str "Entry constr is" ++ fnl () ++
- pr_entry Pcoq.Constr.constr ++
- str "and lconstr is" ++ fnl () ++
- pr_entry Pcoq.Constr.lconstr ++
- str "where binder_constr is" ++ fnl () ++
- pr_entry Pcoq.Constr.binder_constr ++
- str "and operconstr is" ++ fnl () ++
- pr_entry Pcoq.Constr.operconstr
- | "pattern" ->
- pr_entry Pcoq.Constr.pattern
- | "tactic" ->
- str "Entry tactic_expr is" ++ fnl () ++
- pr_entry Pcoq.Tactic.tactic_expr ++
- str "Entry binder_tactic is" ++ fnl () ++
- pr_entry Pcoq.Tactic.binder_tactic ++
- str "Entry simple_tactic is" ++ fnl () ++
- pr_entry Pcoq.Tactic.simple_tactic ++
- str "Entry tactic_arg is" ++ fnl () ++
- pr_entry Pcoq.Tactic.tactic_arg
- | "vernac" ->
- str "Entry vernac is" ++ fnl () ++
- pr_entry Pcoq.Vernac_.vernac ++
- str "Entry command is" ++ fnl () ++
- pr_entry Pcoq.Vernac_.command ++
- str "Entry syntax is" ++ fnl () ++
- pr_entry Pcoq.Vernac_.syntax ++
- str "Entry gallina is" ++ fnl () ++
- pr_entry Pcoq.Vernac_.gallina ++
- str "Entry gallina_ext is" ++ fnl () ++
- pr_entry Pcoq.Vernac_.gallina_ext
- | _ -> error "Unknown or unprintable grammar entry."
-
-(**********************************************************************)
-(* Parse a format (every terminal starting with a letter or a single
- 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
- | _ -> error "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 error "Incorrectly terminated quoted expression." in
- let rec spaces n i =
- if i < String.length str && 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 str.[i] == '\'' && quoted &&
- (i+1 >= String.length str || str.[i+1] == ' ')
- then if Int.equal n 0 then error "Empty quoted token." else n
- else nonspaces quoted (n+1) (i+1)
- else
- if quoted then error "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))
- and parse_quoted n i =
- if i < String.length str 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)))
- (* Parse " .. / .. " *)
- | '/' when i <= String.length str ->
- let p = spaces 0 (i+1) in
- push_token (UnpCut (PpBrk (n,p)))
- (parse_token (close_quotation (i+p+1)))
- | c ->
- (* The spaces are real spaces *)
- push_white n (match c with
- | '[' ->
- if i <= String.length str 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))
- (* Parse " [v .. ", *)
- | 'v' ->
- parse_box (fun n -> PpVB n) (i+2)
- (* Parse " [ .. ", *)
- | ' ' | '\'' ->
- parse_box (fun n -> PpHOVB n) (i+1)
- | _ -> error "\"v\", \"hv\", \" \" expected after \"[\" in format."
- else error "\"v\", \"hv\" or \" \" expected after \"[\" in format."
- (* Parse "]" *)
- | ']' ->
- ([] :: parse_token (close_quotation (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))))
- else
- if Int.equal n 0 then []
- else error "Ending spaces non part of a format annotation."
- and parse_box box i =
- let n = spaces 0 i in
- close_box i (box n) (parse_token (close_quotation (i+n)))
- and parse_token i =
- let n = spaces 0 i in
- let i = i+n in
- if i < l 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)))
- (* Parse the beginning of a quoted expression *)
- | '\'' ->
- parse_quoted (n-1) (i+1)
- (* Otherwise *)
- | _ ->
- push_white (n-1) (parse_non_format i)
- else push_white n [[]]
- in
- try
- if not (String.is_empty str) then match parse_token 0 with
- | [l] -> l
- | _ -> error "Box closed without being opened in format."
- else
- error "Empty format."
- with reraise ->
- let (e, info) = CErrors.push reraise in
- let info = Loc.add_loc info loc in
- iraise (e, info)
-
-(***********************)
-(* Analyzing notations *)
-
-type symbol_token = WhiteSpace of int | String of string
-
-let split_notation_string str =
- let push_token beg i l =
- if Int.equal beg i then l else
- let s = String.sub str beg (i - beg) in
- String s :: l
- in
- let push_whitespace beg i l =
- if Int.equal beg i then l else WhiteSpace (i-beg) :: l
- in
- let rec loop beg i =
- if i < String.length str then
- if str.[i] == ' ' then
- push_token beg i (loop_on_whitespace (i+1) (i+1))
- else
- loop beg (i+1)
- else
- push_token beg i []
- and loop_on_whitespace beg i =
- if i < String.length str then
- if str.[i] != ' ' then
- push_whitespace beg i (loop i (i+1))
- else
- loop_on_whitespace beg (i+1)
- else
- push_whitespace beg i []
- in
- loop 0 0
-
-(* Interpret notations with a recursive component *)
-
-let out_nt = function NonTerminal x -> x | _ -> assert false
-
-let msg_expected_form_of_recursive_notation =
- "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"."
-
-let rec find_pattern nt xl = function
- | Break n as x :: l, Break n' :: l' when Int.equal n n' ->
- find_pattern nt (x::xl) (l,l')
- | Terminal s as x :: l, Terminal s' :: l' when String.equal s s' ->
- find_pattern nt (x::xl) (l,l')
- | [], NonTerminal x' :: l' ->
- (out_nt nt,x',List.rev xl),l'
- | _, Break s :: _ | Break s :: _, _ ->
- error ("A break occurs on one side of \"..\" but not on the other side.")
- | _, Terminal s :: _ | Terminal s :: _, _ ->
- errorlabstrm "Metasyntax.find_pattern"
- (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.")
- | _, [] ->
- error msg_expected_form_of_recursive_notation
- | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) ->
- anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right")
-
-let rec interp_list_parser hd = function
- | [] -> [], List.rev hd
- | NonTerminal id :: tl when Id.equal id ldots_var ->
- if List.is_empty hd then error msg_expected_form_of_recursive_notation;
- let hd = List.rev hd in
- let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in
- let xyl,tl'' = interp_list_parser [] tl' in
- (* We remember each pair of variable denoting a recursive part to *)
- (* remove the second copy of it afterwards *)
- (x,y)::xyl, SProdList (x,sl) :: tl''
- | (Terminal _ | Break _) as s :: tl ->
- if List.is_empty hd then
- let yl,tl' = interp_list_parser [] tl in
- yl, s :: tl'
- else
- interp_list_parser (s::hd) tl
- | NonTerminal _ as x :: tl ->
- let xyl,tl' = interp_list_parser [x] tl in
- xyl, List.rev_append hd tl'
- | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser")
-
-
-(* Find non-terminal tokens of notation *)
-
-(* To protect alphabetic tokens and quotes from being seen as variables *)
-let quote_notation_token x =
- let n = String.length x in
- let norm = CLexer.is_ident x in
- if (n > 0 && norm) || (n > 2 && x.[0] == '\'') then "'"^x^"'"
- else x
-
-let rec raw_analyze_notation_tokens = function
- | [] -> []
- | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl
- | String "_" :: _ -> error "_ must be quoted."
- | String x :: sl when CLexer.is_ident x ->
- NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl
- | String s :: sl ->
- Terminal (String.drop_simple_quotes s) :: raw_analyze_notation_tokens sl
- | WhiteSpace n :: sl ->
- Break n :: raw_analyze_notation_tokens sl
-
-let is_numeral symbs =
- match List.filter (function Break _ -> false | _ -> true) symbs with
- | ([Terminal "-"; Terminal x] | [Terminal x]) ->
- (try let _ = Bigint.of_string x in true with Failure _ -> false)
- | _ ->
- false
-
-let rec get_notation_vars = function
- | [] -> []
- | NonTerminal id :: sl ->
- let vars = get_notation_vars sl in
- if Id.equal id ldots_var then vars else
- if Id.List.mem id vars then
- errorlabstrm "Metasyntax.get_notation_vars"
- (str "Variable " ++ pr_id id ++ str " occurs more than once.")
- else
- id::vars
- | (Terminal _ | Break _) :: sl -> get_notation_vars sl
- | SProdList _ :: _ -> assert false
-
-let analyze_notation_tokens l =
- let l = raw_analyze_notation_tokens l in
- let vars = get_notation_vars l in
- let recvars,l = interp_list_parser [] l in
- recvars, List.subtract Id.equal vars (List.map snd recvars), l
-
-let error_not_same_scope x y =
- errorlabstrm "Metasyntax.error_not_name_scope"
- (str "Variables " ++ pr_id x ++ str " and " ++ pr_id y ++ str " must be in the same scope.")
-
-(**********************************************************************)
-(* Build pretty-printing rules *)
-
-let prec_assoc = function
- | RightA -> (L,E)
- | LeftA -> (E,L)
- | NonA -> (L,L)
-
-let precedence_of_entry_type from = function
- | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n
- | ETConstr (NumLevel n,BorderProd (b,Some a)) ->
- n, let (lp,rp) = prec_assoc a in if b == Left then lp else rp
- | ETConstr (NumLevel n,InternalProd) -> n, Prec n
- | ETConstr (NextLevel,_) -> from, L
- | _ -> 0, E (* ?? *)
-
-(* Some breaking examples *)
-(* "x = y" : "x /1 = y" (breaks before any symbol) *)
-(* "x =S y" : "x /1 =S /1 y" (protect from confusion; each side for symmetry)*)
-(* "+ {" : "+ {" may breaks reversibility without space but oth. not elegant *)
-(* "x y" : "x spc y" *)
-(* "{ x } + { y }" : "{ x } / + { y }" *)
-(* "< x , y > { z , t }" : "< x , / y > / { z , / t }" *)
-
-let starts_with_left_bracket s =
- let l = String.length s in not (Int.equal l 0) &&
- (s.[0] == '{' || s.[0] == '[' || s.[0] == '(')
-
-let ends_with_right_bracket s =
- let l = String.length s in not (Int.equal l 0) &&
- (s.[l-1] == '}' || s.[l-1] == ']' || s.[l-1] == ')')
-
-let is_left_bracket s =
- starts_with_left_bracket s && not (ends_with_right_bracket s)
-
-let is_right_bracket s =
- not (starts_with_left_bracket s) && ends_with_right_bracket s
-
-let is_comma s =
- let l = String.length s in not (Int.equal l 0) &&
- (s.[0] == ',' || s.[0] == ';')
-
-let is_operator s =
- let l = String.length s in not (Int.equal l 0) &&
- (s.[0] == '+' || s.[0] == '*' || s.[0] == '=' ||
- s.[0] == '-' || s.[0] == '/' || s.[0] == '<' || s.[0] == '>' ||
- s.[0] == '@' || s.[0] == '\\' || s.[0] == '&' || s.[0] == '~' || s.[0] == '$')
-
-let is_non_terminal = function
- | NonTerminal _ | SProdList _ -> true
- | _ -> false
-
-let is_next_non_terminal = function
-| [] -> false
-| pr :: _ -> is_non_terminal pr
-
-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_if_none n = function
- | ((UnpCut (PpBrk _) :: _) | []) as l -> l
- | l -> UnpCut (PpBrk(n,0)) :: l
-
-let check_open_binder isopen sl m =
- let pr_token = function
- | Terminal s -> str s
- | Break n -> str "␣"
- | _ -> assert false
- in
- if isopen && not (List.is_empty sl) then
- errorlabstrm "" (str "as " ++ pr_id m ++
- str " is a non-closed binder, no such \"" ++
- prlist_with_sep spc pr_token sl
- ++ strbrk "\" is allowed to occur.")
-
-(* Heuristics for building default printing rules *)
-
-let index_id id l = List.index Id.equal id l
-
-let make_hunks etyps symbols from =
- let vars,typs = List.split etyps in
- let rec make = function
- | NonTerminal m :: prods ->
- let i = index_id m vars in
- 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)
- else
- 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)
- 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)
- else if is_left_bracket s && is_next_non_terminal prods then
- 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
- else
- (* Rely on user spaces *)
- 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)
-
- | Break n :: prods ->
- add_break n (make prods)
-
- | SProdList (m,sl) :: prods ->
- let i = index_id m vars in
- let typ = List.nth typs (i-1) in
- let _,prec = precedence_of_entry_type from typ in
- let sl' =
- (* If no separator: add a break *)
- if List.is_empty sl then add_break 1 []
- (* 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')
- | ETBinder isopen ->
- check_open_binder isopen sl m;
- UnpBinderListMetaVar (i,isopen,sl')
- | _ -> assert false in
- hunk :: make_with_space prods
-
- | [] -> []
-
- and make_with_space prods =
- match prods with
- | 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')
- else if is_comma s' then
- (* No space whatsoever before comma *)
- make prods
- else if is_right_bracket s' then
- make prods
- else
- (* A breakable space between any other two terminals *)
- add_break_if_none 1 (make prods)
- | (NonTerminal _ | SProdList _) :: _ ->
- (* A breakable space before a non-terminal *)
- add_break_if_none 1 (make prods)
- | Break _ :: _ ->
- (* Rely on user wish *)
- make prods
- | [] -> []
-
- in make symbols
-
-(* Build default printing rules from explicit format *)
-
-let error_format () = error "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
- | 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) ->
- (try
- let _ = split_format_at_ldots [] fmt in
- error ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.")
- with Exit -> ())
- | _ -> ()
-
-let skip_var_in_recursive_format = function
- | UnpTerminal _ :: sl (* skip first var *) ->
- (* To do, though not so important: check that the names match
- the names in the notation *)
- sl
- | _ -> error_format ()
-
-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
- let rec get_tail = function
- | a :: sepfmt, b :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *)
- | [], tail -> skip_var_in_recursive_format tail
- | _ -> error "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
- slfmt, get_tail (slfmt, fmt)
-
-let hunks_of_format (from,(vars,typs)) symfmt =
- let rec aux = function
- | 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
- | 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') ->
- 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 ->
- let symbs', b' = aux (symbs,b) in
- let symbs', l = aux (symbs',fmt) in
- symbs', UnpBox (a,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
- let typ = List.nth typs (i-1) in
- 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 ();
- let symbs, l = aux (symbs,fmt) in
- let hunk = match typ with
- | ETConstr _ -> UnpListMetaVar (i,prec,slfmt)
- | ETBinder isopen ->
- check_open_binder isopen sl m;
- UnpBinderListMetaVar (i,isopen,slfmt)
- | _ -> assert false in
- symbs, hunk :: l
- | symbs, [] -> symbs, []
- | _, _ -> error_format ()
- in
- match aux symfmt with
- | [], l -> l
- | _ -> error_format ()
-
-(**********************************************************************)
-(* Build parsing rules *)
-
-let assoc_of_type n (_,typ) = precedence_of_entry_type n typ
-
-let is_not_small_constr = function
- ETConstr _ -> true
- | ETOther("constr","binder_constr") -> true
- | _ -> false
-
-let rec define_keywords_aux = function
- | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l
- when is_not_small_constr e ->
- Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword");
- CLexer.add_keyword k;
- n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l
- | n :: l -> n :: define_keywords_aux l
- | [] -> []
-
- (* Ensure that IDENT articulation terminal symbols are keywords *)
-let define_keywords = function
- | GramConstrTerminal(IDENT k)::l ->
- Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword");
- CLexer.add_keyword k;
- GramConstrTerminal(KEYWORD k) :: define_keywords_aux l
- | l -> define_keywords_aux l
-
-let distribute a ll = List.map (fun l -> a @ l) ll
-
- (* Expand LIST1(t,sep) into the combination of t and t;sep;LIST1(t,sep)
- as many times as expected in [n] argument *)
-let rec expand_list_rule typ tkl x n i hds ll =
- if Int.equal i n then
- let hds =
- GramConstrListMark (n,true) :: hds
- @ [GramConstrNonTerminal (ETConstrList (typ,tkl), Some x)] in
- distribute hds ll
- else
- let camlp4_message_name = Some (add_suffix x ("_"^string_of_int n)) in
- let main = GramConstrNonTerminal (ETConstr typ, camlp4_message_name) in
- let tks = List.map (fun x -> GramConstrTerminal x) tkl in
- distribute (GramConstrListMark (i+1,false) :: hds @ [main]) ll @
- expand_list_rule typ tkl x n (i+1) (main :: tks @ hds) ll
-
-let make_production etyps symbols =
- let prod =
- List.fold_right
- (fun t ll -> match t with
- | NonTerminal m ->
- let typ = List.assoc m etyps in
- distribute [GramConstrNonTerminal (typ, Some m)] ll
- | Terminal s ->
- distribute [GramConstrTerminal (CLexer.terminal s)] ll
- | Break _ ->
- ll
- | SProdList (x,sl) ->
- let tkl = List.flatten
- (List.map (function Terminal s -> [CLexer.terminal s]
- | Break _ -> []
- | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator")) sl) in
- match List.assoc x etyps with
- | ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll
- | ETBinder o ->
- distribute
- [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] ll
- | _ ->
- error "Components of recursive patterns in notation must be terms or binders.")
- symbols [[]] in
- List.map define_keywords prod
-
-let rec find_symbols c_current c_next c_last = function
- | [] -> []
- | NonTerminal id :: sl ->
- let prec = if not (List.is_empty sl) then c_current else c_last in
- (id, prec) :: (find_symbols c_next c_next c_last sl)
- | Terminal s :: sl -> find_symbols c_next c_next c_last sl
- | Break n :: sl -> find_symbols c_current c_next c_last sl
- | SProdList (x,_) :: sl' ->
- (x,c_next)::(find_symbols c_next c_next c_last sl')
-
-let border = function
- | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a
- | _ -> None
-
-let recompute_assoc typs =
- match border typs, border (List.rev typs) with
- | Some LeftA, Some RightA -> assert false
- | Some LeftA, _ -> Some LeftA
- | _, Some RightA -> Some RightA
- | _ -> None
-
-(**************************************************************************)
-(* Registration of syntax extensions (parsing/printing, no interpretation)*)
-
-let pr_arg_level from = function
- | (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) =
- str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++
- prlist_with_sep pr_comma (pr_arg_level from) args
-
-let error_incompatible_level ntn oldprec prec =
- errorlabstrm ""
- (str "Notation " ++ str 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 ".")
-
-type syntax_extension = {
- synext_level : Notation.level;
- synext_notation : notation;
- synext_notgram : notation_grammar;
- synext_unparsing : unparsing list;
- synext_extra : (string * string) list;
- synext_compat : Flags.compat_version option;
-}
-
-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
-
-let cache_one_syntax_extension se =
- let ntn = se.synext_notation in
- let prec = se.synext_level in
- 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
- 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;
- (* Declare the notation rule *)
- Notation.declare_notation_rule ntn
- ~extra:se.synext_extra (se.synext_unparsing, fst prec) se.synext_notgram
- end
-
-let cache_syntax_extension (_, (_, sy)) =
- List.iter 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;
- 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
-
-let inSyntaxExtension : syntax_extension_obj -> obj =
- declare_object {(default_object "SYNTAX-EXTENSION") with
- open_function = (fun i o -> if Int.equal i 1 then cache_syntax_extension o);
- cache_function = cache_syntax_extension;
- subst_function = subst_syntax_extension;
- classify_function = classify_syntax_definition}
-
-(**************************************************************************)
-(* Precedences *)
-
-(* Interpreting user-provided modifiers *)
-
-let interp_modifiers modl =
- let onlyparsing = ref false in
- let onlyprinting = ref false in
- let compat = ref None in
- let rec interp assoc level etyps format extra = function
- | [] ->
- (assoc,level,etyps,!onlyparsing,!onlyprinting,!compat,format,extra)
- | SetEntryType (s,typ) :: l ->
- let id = Id.of_string s in
- if Id.List.mem_assoc id etyps then
- errorlabstrm "Metasyntax.interp_modifiers"
- (str s ++ str " is already assigned to an entry or constr level.");
- interp assoc level ((id,typ)::etyps) format extra l
- | SetItemLevel ([],n) :: l ->
- interp assoc level etyps format extra l
- | SetItemLevel (s::idl,n) :: l ->
- let id = Id.of_string s in
- if Id.List.mem_assoc id etyps then
- errorlabstrm "Metasyntax.interp_modifiers"
- (str s ++ str " is already assigned to an entry or constr level.");
- let typ = ETConstr (n,()) in
- interp assoc level ((id,typ)::etyps) format extra (SetItemLevel (idl,n)::l)
- | SetLevel n :: l ->
- if not (Option.is_empty level) then error "A level is given more than once.";
- interp assoc (Some n) etyps format extra l
- | SetAssoc a :: l ->
- if not (Option.is_empty assoc) then error"An associativity is given more than once.";
- interp (Some a) level etyps format extra l
- | SetOnlyParsing :: l ->
- onlyparsing := true;
- interp assoc level etyps format extra l
- | SetOnlyPrinting :: l ->
- onlyprinting := true;
- interp assoc level etyps format extra l
- | SetCompatVersion v :: l ->
- compat := Some v;
- interp assoc level etyps format extra l
- | SetFormat ("text",s) :: l ->
- if not (Option.is_empty format) then error "A format is given more than once.";
- interp assoc level etyps (Some s) extra l
- | SetFormat (k,(_,s)) :: l ->
- interp assoc level etyps format ((k,s) :: extra) l
- in interp None None [] None [] modl
-
-let check_infix_modifiers modifiers =
- let (_, _, t, _, _, _, _, _) = interp_modifiers modifiers in
- if not (List.is_empty t) then
- error "Explicit entry level or type unexpected in infix notation."
-
-let check_useless_entry_types recvars mainvars etyps =
- let vars = let (l1,l2) = List.split recvars in l1@l2@mainvars in
- match List.filter (fun (x,etyp) -> not (List.mem x vars)) etyps with
- | (x,_)::_ -> errorlabstrm "Metasyntax.check_useless_entry_types"
- (pr_id x ++ str " is unbound in the notation.")
- | _ -> ()
-
-let not_a_syntax_modifier = function
-| SetOnlyParsing -> true
-| SetOnlyPrinting -> true
-| SetCompatVersion _ -> true
-| _ -> false
-
-let no_syntax_modifiers mods = List.for_all not_a_syntax_modifier mods
-
-let is_only_parsing mods =
- let test = function SetOnlyParsing -> true | _ -> false in
- List.exists test mods
-
-let is_only_printing mods =
- let test = function SetOnlyPrinting -> true | _ -> false in
- List.exists test mods
-
-let get_compat_version mods =
- let test = function SetCompatVersion v -> Some v | _ -> None in
- try Some (List.find_map test mods) with Not_found -> None
-
-(* Compute precedences from modifiers (or find default ones) *)
-
-let set_entry_type etyps (x,typ) =
- let typ = try
- match List.assoc x etyps, typ with
- | ETConstr (n,()), (_,BorderProd (left,_)) ->
- ETConstr (n,BorderProd (left,None))
- | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd)
- | (ETPattern | ETName | ETBigint | ETOther _ |
- ETReference | ETBinder _ as t), _ -> t
- | (ETBinderList _ |ETConstrList _), _ -> assert false
- with Not_found -> ETConstr typ
- in (x,typ)
-
-let join_auxiliary_recursive_types recvars etyps =
- List.fold_right (fun (x,y) typs ->
- let xtyp = try Some (List.assoc x etyps) with Not_found -> None in
- let ytyp = try Some (List.assoc y etyps) with Not_found -> None in
- match xtyp,ytyp with
- | None, None -> typs
- | Some _, None -> typs
- | None, Some ytyp -> (x,ytyp)::typs
- | Some xtyp, Some ytyp when Pervasives.(=) xtyp ytyp -> typs (* FIXME *)
- | Some xtyp, Some ytyp ->
- errorlabstrm ""
- (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++
- strbrk ", both ends have incompatible types."))
- recvars etyps
-
-let internalization_type_of_entry_type = function
- | ETConstr _ -> NtnInternTypeConstr
- | ETBigint | ETReference -> NtnInternTypeConstr
- | ETBinder _ -> NtnInternTypeBinder
- | ETName -> NtnInternTypeIdent
- | ETPattern | ETOther _ -> error "Not supported."
- | ETBinderList _ | ETConstrList _ -> assert false
-
-let set_internalization_type typs =
- List.map (fun (_, e) -> internalization_type_of_entry_type e) typs
-
-let make_internalization_vars recvars mainvars typs =
- let maintyps = List.combine mainvars typs in
- let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in
- maintyps @ extratyps
-
-let make_interpretation_type isrec isonlybinding = function
- | NtnInternTypeConstr when isrec -> NtnTypeConstrList
- | NtnInternTypeConstr | NtnInternTypeIdent ->
- if isonlybinding then NtnTypeOnlyBinder else NtnTypeConstr
- | NtnInternTypeBinder when isrec -> NtnTypeBinderList
- | NtnInternTypeBinder -> error "Type binder is only for use in recursive notations for binders."
-
-let make_interpretation_vars recvars allvars =
- let eq_subscope (sc1, l1) (sc2, l2) =
- Option.equal String.equal sc1 sc2 &&
- List.equal String.equal l1 l2
- in
- let check (x, y) =
- let (_,scope1, _) = Id.Map.find x allvars in
- let (_,scope2, _) = Id.Map.find y allvars in
- if not (eq_subscope scope1 scope2) then error_not_same_scope x y
- in
- let () = List.iter check recvars in
- let useless_recvars = List.map snd recvars in
- let mainvars =
- Id.Map.filter (fun x _ -> not (Id.List.mem x useless_recvars)) allvars in
- Id.Map.mapi (fun x (isonlybinding, sc, typ) ->
- (sc, make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding typ)) mainvars
-
-let check_rule_productivity l =
- if List.for_all (function NonTerminal _ | Break _ -> true | _ -> false) l then
- error "A notation must include at least one symbol.";
- if (match l with SProdList _ :: _ -> true | _ -> false) then
- error "A recursive notation must start with at least one symbol."
-
-let warn_notation_bound_to_variable =
- CWarnings.create ~name:"notation-bound-to-variable" ~category:"parsing"
- (fun () ->
- strbrk "This notation will not be used for printing as it is bound to a single variable.")
-
-let warn_non_reversible_notation =
- CWarnings.create ~name:"non-reversible-notation" ~category:"parsing"
- (fun () ->
- strbrk "This notation will not be used for printing as it is not reversible.")
-
-let is_not_printable onlyparse nonreversible = function
-| NVar _ ->
- if not onlyparse then warn_notation_bound_to_variable ();
- true
-| _ ->
- if not onlyparse && nonreversible then
- (warn_non_reversible_notation (); true)
- else onlyparse
-
-let find_precedence lev etyps symbols =
- let first_symbol =
- let rec aux = function
- | Break _ :: t -> aux t
- | h :: t -> h
- | [] -> assert false (* rule is known to be productive *) in
- aux symbols in
- let last_is_terminal () =
- let rec aux b = function
- | Break _ :: t -> aux b t
- | Terminal _ :: t -> aux true t
- | _ :: t -> aux false t
- | [] -> b in
- aux false symbols in
- match first_symbol with
- | NonTerminal x ->
- (try match List.assoc x etyps with
- | ETConstr _ ->
- error "The level of the leftmost non-terminal cannot be changed."
- | ETName | ETBigint | ETReference ->
- begin match lev with
- | None ->
- ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."],0)
- | Some 0 ->
- ([],0)
- | _ ->
- error "A notation starting with an atomic expression must be at level 0."
- end
- | ETPattern | ETBinder _ | ETOther _ -> (* Give a default ? *)
- if Option.is_empty lev then
- error "Need an explicit level."
- else [],Option.get lev
- | ETConstrList _ | ETBinderList _ ->
- assert false (* internally used in grammar only *)
- with Not_found ->
- if Option.is_empty lev then
- error "A left-recursive notation must have an explicit level."
- else [],Option.get lev)
- | Terminal _ when last_is_terminal () ->
- if Option.is_empty lev then
- ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."], 0)
- else [],Option.get lev
- | _ ->
- if Option.is_empty lev then error "Cannot determine the level.";
- [],Option.get lev
-
-let check_curly_brackets_notation_exists () =
- try let _ = Notation.level_of_notation "{ _ }" in ()
- with Not_found ->
- error "Notations involving patterns of the form \"{ _ }\" are treated \n\
-specially and require that the notation \"{ _ }\" is already reserved."
-
-let warn_skip_spaces_curly =
- CWarnings.create ~name:"skip-spaces-curly" ~category:"parsing"
- (fun () ->strbrk "Skipping spaces inside curly brackets")
-
-(* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *)
-let remove_curly_brackets l =
- let rec skip_break acc = function
- | Break _ as br :: l -> skip_break (br::acc) l
- | l -> List.rev acc, l in
- let rec aux deb = function
- | [] -> []
- | Terminal "{" as t1 :: l ->
- let br,next = skip_break [] l in
- (match next with
- | NonTerminal _ as x :: l' as l0 ->
- 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 ();
- if deb && List.is_empty l'' then [t1;x;t2] else begin
- check_curly_brackets_notation_exists ();
- x :: aux false l''
- end
- | l1 -> t1 :: br @ x :: br' @ aux false l1)
- | l0 -> t1 :: aux false l0)
- | x :: l -> x :: aux false l
- in aux true l
-
-let compute_syntax_data df modifiers =
- let (assoc,n,etyps,onlyparse,onlyprint,compat,fmt,extra) = interp_modifiers modifiers in
- let assoc = match assoc with None -> (* default *) Some NonA | a -> a in
- let toks = split_notation_string df in
- let (recvars,mainvars,symbols) = analyze_notation_tokens toks in
- let _ = check_useless_entry_types recvars mainvars etyps in
- let ntn_for_interp = make_notation_key symbols in
- let symbols' = remove_curly_brackets symbols in
- let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in
- let ntn_for_grammar = make_notation_key symbols' in
- check_rule_productivity symbols';
- let msgs,n = find_precedence n 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
- (* To globalize... *)
- let etyps = join_auxiliary_recursive_types recvars etyps in
- let sy_typs = List.map (set_entry_type etyps) typs in
- let prec = (n,List.map (assoc_of_type n) sy_typs) in
- let i_typs = set_internalization_type sy_typs in
- let sy_data = (n,sy_typs,symbols',fmt) in
- let sy_fulldata = (i_typs,ntn_for_grammar,prec,need_squash,sy_data) in
- let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in
- let i_data = (onlyparse,onlyprint,compat,recvars,mainvars,(ntn_for_interp,df')) in
- (* Return relevant data for interpretation and for parsing/printing *)
- (msgs,i_data,i_typs,sy_fulldata,extra)
-
-let compute_pure_syntax_data df mods =
- let (msgs,(onlyparse,onlyprint,_,_,_,_),_,sy_data,extra) = compute_syntax_data df mods in
- let msgs =
- if onlyparse then
- (Feedback.msg_warning ?loc:None,
- strbrk "The only parsing modifier has no effect in Reserved Notation.")::msgs
- else msgs in
- msgs, sy_data, extra, onlyprint
-
-(**********************************************************************)
-(* Registration of notations interpretation *)
-
-type notation_obj = {
- notobj_local : bool;
- notobj_scope : scope_name option;
- notobj_interp : interpretation;
- notobj_onlyparse : bool;
- notobj_onlyprint : bool;
- notobj_compat : Flags.compat_version option;
- notobj_notation : notation * notation_location;
-}
-
-let load_notation _ (_, nobj) =
- Option.iter Notation.declare_scope nobj.notobj_scope
-
-let open_notation i (_, nobj) =
- let scope = nobj.notobj_scope in
- let (ntn, df) = nobj.notobj_notation in
- let pat = nobj.notobj_interp in
- let fresh = not (Notation.exists_notation_in_scope scope ntn pat) in
- let active = is_active_compat nobj.notobj_compat in
- if Int.equal i 1 && fresh && active then begin
- (* Declare the interpretation *)
- let onlyprint = nobj.notobj_onlyprint in
- let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint in
- (* Declare the uninterpretation *)
- if not nobj.notobj_onlyparse then
- Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat
- end
-
-let cache_notation o =
- load_notation 1 o;
- open_notation 1 o
-
-let subst_notation (subst, nobj) =
- { nobj with notobj_interp = subst_interpretation subst nobj.notobj_interp; }
-
-let classify_notation nobj =
- if nobj.notobj_local then Dispose else Substitute nobj
-
-let inNotation : notation_obj -> obj =
- declare_object {(default_object "NOTATION") with
- open_function = open_notation;
- cache_function = cache_notation;
- subst_function = subst_notation;
- load_function = load_notation;
- classify_function = classify_notation}
-
-(**********************************************************************)
-
-let with_lib_stk_protection f x =
- let fs = Lib.freeze `No in
- try let a = f x in Lib.unfreeze fs; a
- with reraise ->
- let reraise = CErrors.push reraise in
- let () = Lib.unfreeze fs in
- iraise reraise
-
-let with_syntax_protection f x =
- with_lib_stk_protection
- (with_grammar_rule_protection
- (with_notation_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 =
- try
- let prec = Notation.level_of_notation ntn in
- let pp_rule,_ = Notation.find_notation_printing_rule ntn in
- let pp_extra_rules = Notation.find_notation_extra_printing_rules ntn in
- let pa_rule = Notation.find_notation_parsing_rules ntn in
- { synext_level = prec;
- synext_notation = ntn;
- synext_notgram = pa_rule;
- synext_unparsing = pp_rule;
- synext_extra = pp_extra_rules;
- synext_compat = None;
- }
- with Not_found ->
- 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
-
-(**********************************************************************)
-(* Main entry point for building parsing and printing rules *)
-
-let make_pa_rule i_typs (n,typs,symbols,_) ntn onlyprint =
- let assoc = recompute_assoc typs in
- let prod = make_production typs symbols in
- { notgram_level = n;
- notgram_assoc = assoc;
- notgram_notation = ntn;
- notgram_prods = prod;
- notgram_typs = i_typs;
- notgram_onlyprinting = onlyprint;
- }
-
-let make_pp_rule (n,typs,symbols,fmt) =
- match fmt with
- | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)]
- | Some fmt -> hunks_of_format (n, List.split typs) (symbols, parse_format fmt)
-
-let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) extra onlyprint compat =
- let pa_rule = make_pa_rule i_typs sy_data ntn onlyprint in
- let pp_rule = make_pp_rule sy_data in
- let sy = {
- synext_level = prec;
- synext_notation = ntn;
- synext_notgram = pa_rule;
- synext_unparsing = pp_rule;
- synext_extra = extra;
- synext_compat = 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 *)
-
-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 (msgs,i_data,i_typs,sy_data,extra) = compute_syntax_data df mods in
- (* Prepare the interpretation *)
- let (onlyparse, onlyprint, compat, recvars,mainvars, df') = i_data in
- (* Prepare the parsing and printing rules *)
- let sy_rules = make_syntax_rules sy_data extra onlyprint compat in
- let i_vars = make_internalization_vars recvars mainvars i_typs in
- let nenv = {
- ninterp_var_type = to_map i_vars;
- ninterp_rec_vars = to_map recvars;
- } in
- let (acvars, ac, reversible) = interp_notation_constr 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
- let notation = {
- notobj_local = local;
- notobj_scope = scope;
- notobj_interp = (List.map_filter map i_vars, ac);
- (** Order is important here! *)
- notobj_onlyparse = onlyparse;
- notobj_onlyprint = onlyprint;
- notobj_compat = compat;
- notobj_notation = df';
- } in
- (* Ready to change the global state *)
- Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs;
- Lib.add_anonymous_leaf (inSyntaxExtension (local, sy_rules));
- Lib.add_anonymous_leaf (inNotation notation);
- df'
-
-let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat =
- let dfs = split_notation_string df in
- let (recvars,mainvars,symbs) = analyze_notation_tokens 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
- (** If the only printing flag has been explicitly requested, put it back *)
- let onlyprint = onlyprint || onlyprint' in
- i_typs, onlyprint
- end else [], false in
- (* Declare interpretation *)
- let path = (Lib.library_dp(),Lib.current_dirpath true) in
- let df' = (make_notation_key symbs,(path,df)) in
- let i_vars = make_internalization_vars recvars mainvars i_typs in
- let nenv = {
- 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 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
- let notation = {
- notobj_local = local;
- notobj_scope = scope;
- notobj_interp = (List.map_filter map i_vars, ac);
- (** Order is important here! *)
- notobj_onlyparse = onlyparse;
- notobj_onlyprint = onlyprint;
- notobj_compat = compat;
- notobj_notation = df';
- } in
- Lib.add_anonymous_leaf (inNotation notation);
- df'
-
-(* Notations without interpretation (Reserved Notation) *)
-
-let add_syntax_extension local ((loc,df),mods) =
- let msgs, sy_data, extra, onlyprint = compute_pure_syntax_data df mods in
- let sy_rules = make_syntax_rules sy_data extra onlyprint None in
- Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs;
- Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules))
-
-(* 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
- Dumpglob.dump_notation (loc,df') sc true
-
-let set_notation_for_interpretation impls ((_,df),c,sc) =
- (try ignore
- (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ());
- with NoSyntaxRule ->
- error "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 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
- with NoSyntaxRule ->
- (* Try to determine a default syntax rule *)
- add_notation_in_scope local df c modifiers sc
- else
- (* Declare both syntax and interpretation *)
- add_notation_in_scope local df c modifiers sc
- in
- Dumpglob.dump_notation (loc,df') sc true
-
-let add_notation_extra_printing_rule df k v =
- let notk =
- let dfs = split_notation_string df in
- let _,_, symbs = analyze_notation_tokens dfs in
- make_notation_key symbs in
- Notation.add_notation_extra_printing_rule notk k v
-
-(* Infix notations *)
-
-let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x),None)
-
-let add_infix local ((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
-
-(**********************************************************************)
-(* Delimiters and classes bound to scopes *)
-
-type scope_command =
- | ScopeDelim of string
- | ScopeClasses of scope_class list
- | ScopeRemove
-
-let load_scope_command _ (_,(scope,dlm)) =
- Notation.declare_scope scope
-
-let open_scope_command i (_,(scope,o)) =
- if Int.equal i 1 then
- match o with
- | ScopeDelim dlm -> Notation.declare_delimiters scope dlm
- | ScopeClasses cl -> List.iter (Notation.declare_scope_class scope) cl
- | ScopeRemove -> Notation.remove_delimiters scope
-
-let cache_scope_command o =
- load_scope_command 1 o;
- open_scope_command 1 o
-
-let subst_scope_command (subst,(scope,o as x)) = match o with
- | ScopeClasses cl ->
- let cl' = List.map_filter (subst_scope_class subst) cl in
- let cl' =
- if List.for_all2eq (==) cl cl' then cl
- else cl' in
- scope, ScopeClasses cl'
- | _ -> x
-
-let inScopeCommand : scope_name * scope_command -> obj =
- declare_object {(default_object "DELIMITERS") with
- cache_function = cache_scope_command;
- open_function = open_scope_command;
- load_function = load_scope_command;
- subst_function = subst_scope_command;
- classify_function = (fun obj -> Substitute obj)}
-
-let add_delimiters scope key =
- Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key))
-
-let remove_delimiters scope =
- Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeRemove))
-
-let add_class_scope scope cl =
- Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl))
-
-(* Check if abbreviation to a name and avoid early insertion of
- maximal implicit arguments *)
-let try_interp_name_alias = function
- | [], CRef (ref,_) -> intern_reference ref
- | _ -> raise Not_found
-
-let add_syntactic_definition ident (vars,c) local onlyparse =
- let nonprintable = ref false in
- let vars,pat =
- try [], NRef (try_interp_name_alias (vars,c))
- with Not_found ->
- let fold accu id = Id.Map.add id NtnInternTypeConstr accu in
- let i_vars = List.fold_left fold Id.Map.empty vars in
- let nenv = {
- ninterp_var_type = i_vars;
- ninterp_rec_vars = Id.Map.empty;
- } in
- let nvars, pat, reversible = interp_notation_constr 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
- in
- let onlyparse = match onlyparse with
- | None when (is_not_printable false !nonprintable pat) -> Some Flags.Current
- | p -> p
- in
- Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat)
-
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
deleted file mode 100644
index 085cc87c..00000000
--- a/toplevel/metasyntax.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open Tacexpr
-open Vernacexpr
-open Notation
-open Constrexpr
-open Notation_term
-
-val add_token_obj : string -> unit
-
-(** Adding a (constr) notation in the environment*)
-
-val add_infix : locality_flag -> (lstring * syntax_modifier list) ->
- constr_expr -> scope_name option -> unit
-
-val add_notation : locality_flag -> constr_expr ->
- (lstring * syntax_modifier list) -> scope_name option -> unit
-
-val add_notation_extra_printing_rule : string -> string -> string -> unit
-
-(** Declaring delimiter keys and default scopes *)
-
-val add_delimiters : scope_name -> string -> unit
-val remove_delimiters : scope_name -> unit
-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
-
-(** Add a notation interpretation for supporting the "where" clause *)
-
-val set_notation_for_interpretation : Constrintern.internalization_env ->
- (lstring * constr_expr * scope_name option) -> unit
-
-(** Add only the parsing/printing rule of a notation *)
-
-val add_syntax_extension :
- locality_flag -> (lstring * syntax_modifier list) -> unit
-
-(** Add a syntactic definition (as in "Notation f := ...") *)
-
-val add_syntactic_definition : Id.t -> Id.t list * constr_expr ->
- bool -> Flags.compat_version option -> unit
-
-(** Print the Camlp4 state of a grammar *)
-
-val pr_grammar : string -> Pp.std_ppcmds
-
-val check_infix_modifiers : syntax_modifier list -> unit
-
-val with_syntax_protection : ('a -> 'b) -> 'a -> 'b
diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml
deleted file mode 100644
index b6690fe4..00000000
--- a/toplevel/mltop.ml
+++ /dev/null
@@ -1,447 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open CErrors
-open Util
-open Pp
-open Flags
-open Libobject
-open System
-
-(* Code to hook Coq into the ML toplevel -- depends on having the
- objective-caml compiler mostly visible. The functions implemented here are:
- \begin{itemize}
- \item [dir_ml_load name]: Loads the ML module fname from the current ML
- path.
- \item [dir_ml_use]: Directive #use of Ocaml toplevel
- \item [add_ml_dir]: Directive #directory of Ocaml toplevel
- \end{itemize}
-
- How to build an ML module interface with these functions.
- The idea is that the ML directory path is like the Coq directory
- path. So we can maintain the two in parallel.
- In the same way, we can use the "ml_env" as a kind of ML
- environment, which we freeze, unfreeze, and add things to just like
- to the other environments.
- Finally, we can create an object which is an ML module, and require
- that the "caching" of the ML module cause the loading of the
- associated ML file, if that file has not been yet loaded. Of
- course, the problem is how to record dependencies between ML
- modules.
- (I do not know of a solution to this problem, other than to
- put all the needed names into the ML Module object.) *)
-
-
-(* NB: this module relies on OCaml's Dynlink library. The bytecode version
- of Dynlink is always available, but there are some architectures
- with native compilation and no dynlink.cmxa. Instead of nasty IFDEF's
- here for hiding the calls to Dynlink, we now simply reject this rather
- rare situation during ./configure, and give instructions there about how
- to build a dummy dynlink.cmxa, cf. dev/dynlink.ml. *)
-
-(* This path is where we look for .cmo *)
-let coq_mlpath_copy = ref [Sys.getcwd ()]
-let keep_copy_mlpath path =
- let cpath = CUnix.canonical_path_name path in
- let filter path' = not (String.equal cpath path')
- in
- coq_mlpath_copy := cpath :: List.filter filter !coq_mlpath_copy
-
-(* If there is a toplevel under Coq *)
-type toplevel = {
- load_obj : string -> unit;
- use_file : string -> unit;
- add_dir : string -> unit;
- ml_loop : unit -> unit }
-
-(* Determines the behaviour of Coq with respect to ML files (compiled
- or not) *)
-type kind_load =
- | WithTop of toplevel
- | WithoutTop
-
-(* Must be always initialized *)
-let load = ref WithoutTop
-
-(* Are we in a native version of Coq? *)
-let is_native = Dynlink.is_native
-
-(* Sets and initializes a toplevel (if any) *)
-let set_top toplevel = load :=
- WithTop toplevel;
- Nativelib.load_obj := toplevel.load_obj
-
-(* Removes the toplevel (if any) *)
-let remove () =
- load := WithoutTop;
- Nativelib.load_obj := (fun x -> () : string -> unit)
-
-(* Tests if an Ocaml toplevel runs under Coq *)
-let is_ocaml_top () =
- match !load with
- | WithTop _ -> true
- |_ -> false
-
-(* Tests if we can load ML files *)
-let has_dynlink = Coq_config.has_natdynlink || not is_native
-
-(* Runs the toplevel loop of Ocaml *)
-let ocaml_toploop () =
- match !load with
- | WithTop t -> Printexc.catch t.ml_loop ()
- | _ -> ()
-
-(* Try to interpret load_obj's (internal) errors *)
-let report_on_load_obj_error exc =
- let x = Obj.repr exc in
- (* Try an horrible (fragile) hack to report on Symtable dynlink errors *)
- (* (we follow ocaml's Printexc.to_string decoding of exceptions) *)
- if Obj.is_block x && String.equal (Obj.magic (Obj.field (Obj.field x 0) 0)) "Symtable.Error"
- then
- let err_block = Obj.field x 1 in
- if Int.equal (Obj.tag err_block) 0 then
- (* Symtable.Undefined_global of string *)
- str "reference to undefined global " ++
- str (Obj.magic (Obj.field err_block 0))
- else str (Printexc.to_string exc)
- else str (Printexc.to_string exc)
-
-(* Dynamic loading of .cmo/.cma *)
-
-let ml_load s =
- match !load with
- | WithTop t ->
- (try t.load_obj s; s
- with
- | e when CErrors.noncritical e ->
- let e = CErrors.push e in
- match fst e with
- | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e)
- | exc ->
- let msg = report_on_load_obj_error exc in
- errorlabstrm "Mltop.load_object" (str"Cannot link ml-object " ++
- str s ++ str" to Coq code (" ++ msg ++ str ")."))
- | WithoutTop ->
- try
- Dynlink.loadfile s; s
- with Dynlink.Error a ->
- errorlabstrm "Mltop.load_object"
- (strbrk "while loading " ++ str s ++
- strbrk ": " ++ str (Dynlink.error_message a))
-
-let dir_ml_load s =
- match !load with
- | WithTop _ -> ml_load s
- | WithoutTop ->
- let warn = Flags.is_verbose() in
- let _,gname = find_file_in_path ~warn !coq_mlpath_copy s in
- ml_load gname
-
-(* Dynamic interpretation of .ml *)
-let dir_ml_use s =
- match !load with
- | WithTop t -> t.use_file s
- | _ ->
- let moreinfo =
- if Dynlink.is_native then " Loading ML code works only in bytecode."
- else ""
- in
- errorlabstrm "Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo)
-
-(* Adds a path to the ML paths *)
-let add_ml_dir s =
- match !load with
- | WithTop t -> t.add_dir s; keep_copy_mlpath s
- | WithoutTop when has_dynlink -> keep_copy_mlpath s
- | _ -> ()
-
-(* For Rec Add ML Path (-R) *)
-let add_rec_ml_dir unix_path =
- List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path)
-
-(* Adding files to Coq and ML loadpath *)
-
-let warn_cannot_use_directory =
- CWarnings.create ~name:"cannot-use-directory" ~category:"filesystem"
- (fun d ->
- str "Directory " ++ str d ++
- strbrk " cannot be used as a Coq identifier (skipped)")
-
-let convert_string d =
- try Names.Id.of_string d
- with UserError _ ->
- warn_cannot_use_directory d;
- raise Exit
-
-let warn_cannot_open_path =
- CWarnings.create ~name:"cannot-open-path" ~category:"filesystem"
- (fun unix_path -> str "Cannot open " ++ str unix_path)
-
-type add_ml = AddNoML | AddTopML | AddRecML
-
-let add_rec_path add_ml ~unix_path ~coq_root ~implicit =
- if exists_dir unix_path then
- let dirs = all_subdirs ~unix_path in
- let prefix = Names.DirPath.repr coq_root in
- let convert_dirs (lp, cp) =
- try
- let path = List.rev_map convert_string cp @ prefix in
- Some (lp, Names.DirPath.make path)
- with Exit -> None
- in
- let dirs = List.map_filter convert_dirs dirs in
- let () = match add_ml with
- | AddNoML -> ()
- | AddTopML -> add_ml_dir unix_path
- | AddRecML -> List.iter (fun (lp,_) -> add_ml_dir lp) dirs in
- let add (path, dir) =
- Loadpath.add_load_path path ~implicit dir in
- let () = List.iter add dirs in
- Loadpath.add_load_path unix_path ~implicit coq_root
- else
- warn_cannot_open_path unix_path
-
-(* convertit un nom quelconque en nom de fichier ou de module *)
-let mod_of_name name =
- if Filename.check_suffix name ".cmo" then
- Filename.chop_suffix name ".cmo"
- else
- name
-
-let get_ml_object_suffix name =
- if Filename.check_suffix name ".cmo" then
- Some ".cmo"
- else if Filename.check_suffix name ".cma" then
- Some ".cma"
- else if Filename.check_suffix name ".cmxs" then
- Some ".cmxs"
- else
- None
-
-let file_of_name name =
- let suffix = get_ml_object_suffix name in
- let fail s =
- errorlabstrm "Mltop.load_object"
- (str"File not found on loadpath : " ++ str s ++ str"\n" ++
- str"Loadpath: " ++ str(String.concat ":" !coq_mlpath_copy)) in
- if not (Filename.is_relative name) then
- if Sys.file_exists name then name else fail name
- else if is_native then
- let name = match suffix with
- | Some ((".cmo"|".cma") as suffix) ->
- (Filename.chop_suffix name suffix) ^ ".cmxs"
- | Some ".cmxs" -> name
- | _ -> name ^ ".cmxs"
- in
- if is_in_path !coq_mlpath_copy name then name else fail name
- else
- let (full, base) = match suffix with
- | Some ".cmo" | Some ".cma" -> true, name
- | Some ".cmxs" -> false, Filename.chop_suffix name ".cmxs"
- | _ -> false, name
- in
- if full then
- if is_in_path !coq_mlpath_copy base then base else fail base
- else
- let name = base ^ ".cma" in
- if is_in_path !coq_mlpath_copy name then name else
- let name = base ^ ".cmo" in
- if is_in_path !coq_mlpath_copy name then name else
- fail (base ^ ".cm[ao]")
-
-(** Is the ML code of the standard library placed into loadable plugins
- or statically compiled into coqtop ? For the moment this choice is
- made according to the presence of native dynlink : even if bytecode
- coqtop could always load plugins, we prefer to have uniformity between
- bytecode and native versions. *)
-
-(* [known_loaded_module] contains the names of the loaded ML modules
- * (linked or loaded with load_object). It is used not to load a
- * module twice. It is NOT the list of ML modules Coq knows. *)
-
-let known_loaded_modules = ref String.Map.empty
-
-let add_known_module mname path =
- if not (String.Map.mem mname !known_loaded_modules) ||
- String.Map.find mname !known_loaded_modules = None then
- known_loaded_modules := String.Map.add mname path !known_loaded_modules
-
-let module_is_known mname =
- String.Map.mem mname !known_loaded_modules
-
-let known_module_path mname =
- String.Map.find mname !known_loaded_modules
-
-(** A plugin is just an ML module with an initialization function. *)
-
-let known_loaded_plugins = ref String.Map.empty
-
-let add_known_plugin init name =
- add_known_module name None;
- known_loaded_plugins := String.Map.add name init !known_loaded_plugins
-
-let init_known_plugins () =
- String.Map.iter (fun _ f -> f()) !known_loaded_plugins
-
-(** Registering functions to be used at caching time, that is when the Declare
- ML module command is issued. *)
-
-let cache_objs = ref String.Map.empty
-
-let declare_cache_obj f name =
- let objs = try String.Map.find name !cache_objs with Not_found -> [] in
- let objs = f :: objs in
- cache_objs := String.Map.add name objs !cache_objs
-
-let perform_cache_obj name =
- let objs = try String.Map.find name !cache_objs with Not_found -> [] in
- let objs = List.rev objs in
- List.iter (fun f -> f ()) objs
-
-(** ml object = ml module or plugin *)
-
-let init_ml_object mname =
- try String.Map.find mname !known_loaded_plugins ()
- with Not_found -> ()
-
-let load_ml_object mname ?path fname=
- let path = match path with
- | None -> dir_ml_load fname
- | Some p -> ml_load p in
- add_known_module mname (Some path);
- init_ml_object mname;
- path
-
-let dir_ml_load m = ignore(dir_ml_load m)
-let add_known_module m = add_known_module m None
-let load_ml_object_raw fname = dir_ml_load (file_of_name fname)
-let load_ml_objects_raw_rex rex =
- List.iter (fun (_,fp) ->
- let name = file_of_name (Filename.basename fp) in
- try dir_ml_load name
- with e -> prerr_endline (Printexc.to_string e))
- (System.where_in_path_rex !coq_mlpath_copy rex)
-
-(* Summary of declared ML Modules *)
-
-(* List and not String.Set because order is important: most recent first. *)
-
-let loaded_modules = ref []
-let get_loaded_modules () = List.rev !loaded_modules
-let add_loaded_module md path =
- if not (List.mem_assoc md !loaded_modules) then
- loaded_modules := (md,path) :: !loaded_modules
-let reset_loaded_modules () = loaded_modules := []
-
-let if_verbose_load verb f name ?path fname =
- if not verb then f name ?path fname
- else
- let info = str "[Loading ML file " ++ str fname ++ str " ..." in
- try
- let path = f name ?path fname in
- Feedback.msg_info (info ++ str " done]");
- path
- with reraise ->
- Feedback.msg_info (info ++ str " failed]");
- raise reraise
-
-(** Load a module for the first time (i.e. dynlink it)
- or simulate its reload (i.e. doing nothing except maybe
- an initialization function). *)
-
-let trigger_ml_object verb cache reinit ?path name =
- if module_is_known name then begin
- if reinit then init_ml_object name;
- add_loaded_module name (known_module_path name);
- if cache then perform_cache_obj name
- end else if not has_dynlink then
- errorlabstrm "Mltop.trigger_ml_object"
- (str "Dynamic link not supported (module " ++ str name ++ str ")")
- else begin
- let file = file_of_name (Option.default name path) in
- let path =
- if_verbose_load (verb && is_verbose ()) load_ml_object name ?path file in
- add_loaded_module name (Some path);
- if cache then perform_cache_obj name
- end
-
-let load_ml_object n m = ignore(load_ml_object n m)
-
-let unfreeze_ml_modules x =
- reset_loaded_modules ();
- List.iter
- (fun (name,path) -> trigger_ml_object false false false ?path name) x
-
-let _ =
- Summary.declare_summary Summary.ml_modules
- { Summary.freeze_function = (fun _ -> get_loaded_modules ());
- Summary.unfreeze_function = unfreeze_ml_modules;
- Summary.init_function = reset_loaded_modules }
-
-(* Liboject entries of declared ML Modules *)
-
-type ml_module_object = {
- mlocal : Vernacexpr.locality_flag;
- mnames : string list
-}
-
-let cache_ml_objects (_,{mnames=mnames}) =
- let iter obj = trigger_ml_object true true true obj in
- List.iter iter mnames
-
-let load_ml_objects _ (_,{mnames=mnames}) =
- let iter obj = trigger_ml_object true false true obj in
- List.iter iter mnames
-
-let classify_ml_objects ({mlocal=mlocal} as o) =
- if mlocal then Dispose else Substitute o
-
-let inMLModule : ml_module_object -> obj =
- declare_object
- {(default_object "ML-MODULE") with
- cache_function = cache_ml_objects;
- load_function = load_ml_objects;
- subst_function = (fun (_,o) -> o);
- classify_function = classify_ml_objects }
-
-let declare_ml_modules local l =
- let l = List.map mod_of_name l in
- Lib.add_anonymous_leaf ~cache_first:false (inMLModule {mlocal=local; mnames=l})
-
-let print_ml_path () =
- let l = !coq_mlpath_copy in
- str"ML Load Path:" ++ fnl () ++ str" " ++
- hv 0 (prlist_with_sep fnl str l)
-
-(* Printing of loaded ML modules *)
-
-let print_ml_modules () =
- let l = get_loaded_modules () in
- str"Loaded ML Modules: " ++ pr_vertical_list str (List.map fst l)
-
-let print_gc () =
- let stat = Gc.stat () in
- let msg =
- str "minor words: " ++ real stat.Gc.minor_words ++ fnl () ++
- str "promoted words: " ++ real stat.Gc.promoted_words ++ fnl () ++
- str "major words: " ++ real stat.Gc.major_words ++ fnl () ++
- str "minor_collections: " ++ int stat.Gc.minor_collections ++ fnl () ++
- str "major_collections: " ++ int stat.Gc.major_collections ++ fnl () ++
- str "heap_words: " ++ int stat.Gc.heap_words ++ fnl () ++
- str "heap_chunks: " ++ int stat.Gc.heap_chunks ++ fnl () ++
- str "live_words: " ++ int stat.Gc.live_words ++ fnl () ++
- str "live_blocks: " ++ int stat.Gc.live_blocks ++ fnl () ++
- str "free_words: " ++ int stat.Gc.free_words ++ fnl () ++
- str "free_blocks: " ++ int stat.Gc.free_blocks ++ fnl () ++
- str "largest_free: " ++ int stat.Gc.largest_free ++ fnl () ++
- str "fragments: " ++ int stat.Gc.fragments ++ fnl () ++
- str "compactions: " ++ int stat.Gc.compactions ++ fnl () ++
- str "top_heap_words: " ++ int stat.Gc.top_heap_words ++ fnl () ++
- str "stack_size: " ++ int stat.Gc.stack_size
- in
- hv 0 msg
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
deleted file mode 100644
index 6633cb93..00000000
--- a/toplevel/mltop.mli
+++ /dev/null
@@ -1,88 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(** {5 Toplevel management} *)
-
-(** If there is a toplevel under Coq, it is described by the following
- record. *)
-type toplevel = {
- load_obj : string -> unit;
- use_file : string -> unit;
- add_dir : string -> unit;
- ml_loop : unit -> unit }
-
-(** Sets and initializes a toplevel (if any) *)
-val set_top : toplevel -> unit
-
-(** Are we in a native version of Coq? *)
-val is_native : bool
-
-(** Removes the toplevel (if any) *)
-val remove : unit -> unit
-
-(** Tests if an Ocaml toplevel runs under Coq *)
-val is_ocaml_top : unit -> bool
-
-(** Starts the Ocaml toplevel loop *)
-val ocaml_toploop : unit -> unit
-
-(** {5 ML Dynlink} *)
-
-(** Tests if we can load ML files *)
-val has_dynlink : bool
-
-(** Dynamic loading of .cmo *)
-val dir_ml_load : string -> unit
-
-(** Dynamic interpretation of .ml *)
-val dir_ml_use : string -> unit
-
-(** Adds a path to the ML paths *)
-val add_ml_dir : string -> unit
-val add_rec_ml_dir : string -> unit
-
-type add_ml = AddNoML | AddTopML | AddRecML
-
-(** Adds a path to the Coq and ML paths *)
-val add_rec_path : add_ml -> unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit
-
-(** List of modules linked to the toplevel *)
-val add_known_module : string -> unit
-val module_is_known : string -> bool
-val load_ml_object : string -> string -> unit
-val load_ml_object_raw : string -> unit
-val load_ml_objects_raw_rex : Str.regexp -> unit
-
-(** {5 Initialization functions} *)
-
-(** Declare a plugin and its initialization function.
- A plugin is just an ML module with an initialization function.
- Adding a known plugin implies adding it as a known ML module.
- The initialization function is granted to be called after Coq is fully
- bootstrapped, even if the plugin is statically linked with the toplevel *)
-val add_known_plugin : (unit -> unit) -> string -> unit
-
-(** Calls all initialization functions in a non-specified order *)
-val init_known_plugins : unit -> unit
-
-(** Register a callback that will be called when the module is declared with
- the Declare ML Module command. This is useful to define Coq objects at that
- time only. Several functions can be defined for one module; they will be
- called in the order of declaration, and after the ML module has been
- properly initialized. *)
-val declare_cache_obj : (unit -> unit) -> string -> unit
-
-(** {5 Declaring modules} *)
-
-val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit
-
-(** {5 Utilities} *)
-
-val print_ml_path : unit -> Pp.std_ppcmds
-val print_ml_modules : unit -> Pp.std_ppcmds
-val print_gc : unit -> Pp.std_ppcmds
diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml
deleted file mode 100644
index 29d74573..00000000
--- a/toplevel/obligations.ml
+++ /dev/null
@@ -1,1171 +0,0 @@
-open Printf
-open Globnames
-open Libobject
-open Entries
-open Decl_kinds
-open Declare
-
-(**
- - Get types of existentials ;
- - Flatten dependency tree (prefix order) ;
- - Replace existentials by De Bruijn indices in term, applied to the right arguments ;
- - Apply term prefixed by quantification on "existentials".
-*)
-
-open Term
-open Vars
-open Names
-open Evd
-open Pp
-open CErrors
-open Util
-
-let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false)
-let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false)
-
-let succfix (depth, fixrels) =
- (succ depth, List.map succ fixrels)
-
-let check_evars env evm =
- Evar.Map.iter
- (fun key evi ->
- let (loc,k) = evar_source key evm in
- match k with
- | Evar_kinds.QuestionMark _
- | Evar_kinds.ImplicitArg (_,_,false) -> ()
- | _ ->
- Pretype_errors.error_unsolvable_implicit loc env evm key None)
- (Evd.undefined_map evm)
-
-type oblinfo =
- { ev_name: int * Id.t;
- ev_hyps: Context.Named.t;
- ev_status: bool * Evar_kinds.obligation_definition_status;
- ev_chop: int option;
- ev_src: Evar_kinds.t Loc.located;
- ev_typ: types;
- ev_tac: unit Proofview.tactic option;
- ev_deps: Int.Set.t }
-
-(** Substitute evar references in t using De Bruijn indices,
- where n binders were passed through. *)
-
-let subst_evar_constr evs n idf t =
- let open Context.Named.Declaration in
- let seen = ref Int.Set.empty in
- let transparent = ref Id.Set.empty in
- let evar_info id = List.assoc_f Evar.equal id evs in
- let rec substrec (depth, fixrels) c = match kind_of_term c with
- | Evar (k, args) ->
- let { ev_name = (id, idstr) ;
- ev_hyps = hyps ; ev_chop = chop } =
- try evar_info k
- with Not_found ->
- anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found")
- in
- seen := Int.Set.add id !seen;
- (* Evar arguments are created in inverse order,
- and we must not apply to defined ones (i.e. LetIn's)
- *)
- let args =
- let n = match chop with None -> 0 | Some c -> c in
- let (l, r) = List.chop n (List.rev (Array.to_list args)) in
- List.rev r
- in
- let args =
- let rec aux hyps args acc =
- match hyps, args with
- (LocalAssum _ :: tlh), (c :: tla) ->
- aux tlh tla ((substrec (depth, fixrels) c) :: acc)
- | (LocalDef _ :: tlh), (_ :: tla) ->
- aux tlh tla acc
- | [], [] -> acc
- | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
- in aux hyps args []
- in
- if List.exists
- (fun x -> match kind_of_term x with
- | Rel n -> Int.List.mem n fixrels
- | _ -> false) args
- then
- transparent := Id.Set.add idstr !transparent;
- mkApp (idf idstr, Array.of_list args)
- | Fix _ ->
- map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c
- | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c
- in
- let t' = substrec (0, []) t in
- t', !seen, !transparent
-
-
-(** Substitute variable references in t using De Bruijn indices,
- where n binders were passed through. *)
-let subst_vars acc n t =
- let var_index id = Util.List.index Id.equal id acc in
- let rec substrec depth c = match kind_of_term c with
- | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c)
- | _ -> map_constr_with_binders succ substrec depth c
- in
- substrec 0 t
-
-(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ])
- to a product : forall H1 : t1, ..., forall Hn : tn, concl.
- Changes evars and hypothesis references to variable references.
-*)
-let etype_of_evar evs hyps concl =
- let open Context.Named.Declaration in
- let rec aux acc n = function
- decl :: tl ->
- let t', s, trans = subst_evar_constr evs n mkVar (get_type decl) in
- let t'' = subst_vars acc 0 t' in
- let rest, s', trans' = aux (get_id decl :: acc) (succ n) tl in
- let s' = Int.Set.union s s' in
- let trans' = Id.Set.union trans trans' in
- (match decl with
- | LocalDef (id,c,_) ->
- let c', s'', trans'' = subst_evar_constr evs n mkVar c in
- let c' = subst_vars acc 0 c' in
- mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest,
- Int.Set.union s'' s',
- Id.Set.union trans'' trans'
- | LocalAssum (id,_) ->
- mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans')
- | [] ->
- let t', s, trans = subst_evar_constr evs n mkVar concl in
- subst_vars acc 0 t', s, trans
- in aux [] 0 (List.rev hyps)
-
-let trunc_named_context n ctx =
- let len = List.length ctx in
- List.firstn (len - n) ctx
-
-let rec chop_product n t =
- if Int.equal n 0 then Some t
- else
- match kind_of_term t with
- | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
- | _ -> None
-
-let evar_dependencies evm oev =
- let one_step deps =
- Evar.Set.fold (fun ev s ->
- let evi = Evd.find evm ev in
- let deps' = evars_of_filtered_evar_info evi in
- if Evar.Set.mem oev deps' then
- invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ string_of_existential oev)
- else Evar.Set.union deps' s)
- deps deps
- in
- let rec aux deps =
- let deps' = one_step deps in
- if Evar.Set.equal deps deps' then deps
- else aux deps'
- in aux (Evar.Set.singleton oev)
-
-let move_after (id, ev, deps as obl) l =
- let rec aux restdeps = function
- | (id', _, _) as obl' :: tl ->
- let restdeps' = Evar.Set.remove id' restdeps in
- if Evar.Set.is_empty restdeps' then
- obl' :: obl :: tl
- else obl' :: aux restdeps' tl
- | [] -> [obl]
- in aux (Evar.Set.remove id deps) l
-
-let sort_dependencies evl =
- let rec aux l found list =
- match l with
- | (id, ev, deps) as obl :: tl ->
- let found' = Evar.Set.union found (Evar.Set.singleton id) in
- if Evar.Set.subset deps found' then
- aux tl found' (obl :: list)
- else aux (move_after obl tl) found list
- | [] -> List.rev list
- in aux evl Evar.Set.empty []
-
-open Environ
-
-let eterm_obligations env name evm fs ?status t ty =
- (* 'Serialize' the evars *)
- let nc = Environ.named_context env in
- let nc_len = Context.Named.length nc in
- let evm = Evarutil.nf_evar_map_undefined evm in
- let evl = Evarutil.non_instantiated evm in
- let evl = Evar.Map.bindings evl in
- let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in
- let sevl = sort_dependencies evl in
- let evl = List.map (fun (id, ev, _) -> id, ev) sevl in
- let evn =
- let i = ref (-1) in
- List.rev_map (fun (id, ev) -> incr i;
- (id, (!i, Id.of_string
- (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))),
- ev)) evl
- in
- let evts =
- (* Remove existential variables in types and build the corresponding products *)
- List.fold_right
- (fun (id, (n, nstr), ev) l ->
- let hyps = Evd.evar_filtered_context ev in
- let hyps = trunc_named_context nc_len hyps in
- let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in
- let evtyp, hyps, chop =
- match chop_product fs evtyp with
- | Some t -> t, trunc_named_context fs hyps, fs
- | None -> evtyp, hyps, 0
- in
- let loc, k = evar_source id evm in
- let status = match k with
- | Evar_kinds.QuestionMark o -> o
- | _ -> match status with
- | Some o -> o
- | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ()))
- in
- let force_status, status, chop = match status with
- | Evar_kinds.Define true as stat ->
- if not (Int.equal chop fs) then true, Evar_kinds.Define false, None
- else false, stat, Some chop
- | s -> false, s, None
- in
- let info = { ev_name = (n, nstr);
- ev_hyps = hyps; ev_status = force_status, status; ev_chop = chop;
- ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None }
- in (id, info) :: l)
- evn []
- in
- let t', _, transparent = (* Substitute evar refs in the term by variables *)
- subst_evar_constr evts 0 mkVar t
- in
- let ty, _, _ = subst_evar_constr evts 0 mkVar ty in
- let evars =
- List.map (fun (ev, info) ->
- let { ev_name = (_, name); ev_status = force_status, status;
- ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info
- in
- let force_status, status = match status with
- | Evar_kinds.Define true when Id.Set.mem name transparent ->
- true, Evar_kinds.Define false
- | _ -> force_status, status
- in name, typ, src, (force_status, status), deps, tac) evts
- in
- let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in
- let evmap f c = pi1 (subst_evar_constr evts 0 f c) in
- Array.of_list (List.rev evars), (evnames, evmap), t', ty
-
-let tactics_module = ["Program";"Tactics"]
-let safe_init_constant md name () =
- Coqlib.check_required_library ("Coq"::md);
- Coqlib.gen_constant "Obligations" md name
-let hide_obligation = safe_init_constant tactics_module "obligation"
-
-let pperror cmd = CErrors.errorlabstrm "Program" cmd
-let error s = pperror (str s)
-
-let reduce c =
- Reductionops.clos_norm_flags CClosure.betaiota (Global.env ()) Evd.empty c
-
-exception NoObligations of Id.t option
-
-let explain_no_obligations = function
- Some ident -> str "No obligations for program " ++ Id.print ident
- | None -> str "No obligations remaining"
-
-type obligation_info =
- (Names.Id.t * Term.types * Evar_kinds.t Loc.located *
- (bool * Evar_kinds.obligation_definition_status)
- * Int.Set.t * unit Proofview.tactic option) array
-
-type 'a obligation_body =
- | DefinedObl of 'a
- | TermObl of constr
-
-type obligation =
- { obl_name : Id.t;
- obl_type : types;
- obl_location : Evar_kinds.t Loc.located;
- obl_body : constant obligation_body option;
- obl_status : bool * Evar_kinds.obligation_definition_status;
- obl_deps : Int.Set.t;
- obl_tac : unit Proofview.tactic option;
- }
-
-type obligations = (obligation array * int)
-
-type fixpoint_kind =
- | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list
- | IsCoFixpoint
-
-type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list
-
-type program_info_aux = {
- prg_name: Id.t;
- prg_body: constr;
- prg_type: constr;
- prg_ctx: Evd.evar_universe_context;
- prg_pl: Id.t Loc.located list option;
- prg_obligations: obligations;
- prg_deps : Id.t list;
- prg_fixkind : fixpoint_kind option ;
- prg_implicits : (Constrexpr.explicitation * (bool * bool * bool)) list;
- prg_notations : notations ;
- prg_kind : definition_kind;
- prg_reduce : constr -> constr;
- prg_hook : (Evd.evar_universe_context -> unit) Lemmas.declaration_hook;
- prg_opaque : bool;
- prg_sign: named_context_val;
-}
-
-type program_info = program_info_aux CEphemeron.key
-
-let get_info x =
- try CEphemeron.get x
- with CEphemeron.InvalidKey ->
- CErrors.anomaly Pp.(str "Program obligation can't be accessed by a worker")
-
-let assumption_message = Declare.assumption_message
-
-let default_tactic = ref (Proofview.tclUNIT ())
-
-(* true = hide obligations *)
-let hide_obligations = ref false
-
-let set_hide_obligations = (:=) hide_obligations
-let get_hide_obligations () = !hide_obligations
-
-open Goptions
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "Hidding of Program obligations";
- optkey = ["Hide";"Obligations"];
- optread = get_hide_obligations;
- optwrite = set_hide_obligations; }
-
-let shrink_obligations = ref true
-
-let set_shrink_obligations = (:=) shrink_obligations
-let get_shrink_obligations () = !shrink_obligations
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = true;
- optname = "Shrinking of Program obligations";
- optkey = ["Shrink";"Obligations"];
- optread = get_shrink_obligations;
- optwrite = set_shrink_obligations; }
-
-let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
-
-let get_body obl =
- match obl.obl_body with
- | None -> None
- | Some (DefinedObl c) ->
- let ctx = Environ.constant_context (Global.env ()) c in
- let pc = (c, Univ.UContext.instance ctx) in
- Some (DefinedObl pc)
- | Some (TermObl c) ->
- Some (TermObl c)
-
-let get_obligation_body expand obl =
- match get_body obl with
- | None -> None
- | Some c ->
- if expand && snd obl.obl_status == Evar_kinds.Expand then
- match c with
- | DefinedObl pc -> Some (constant_value_in (Global.env ()) pc)
- | TermObl c -> Some c
- else (match c with
- | DefinedObl pc -> Some (mkConstU pc)
- | TermObl c -> Some c)
-
-let obl_substitution expand obls deps =
- Int.Set.fold
- (fun x acc ->
- let xobl = obls.(x) in
- match get_obligation_body expand xobl with
- | None -> acc
- | Some oblb -> (xobl.obl_name, (xobl.obl_type, oblb)) :: acc)
- deps []
-
-let subst_deps expand obls deps t =
- let osubst = obl_substitution expand obls deps in
- (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t)
-
-let rec prod_app t n =
- match kind_of_term (strip_outer_cast t) with
- | Prod (_,_,b) -> subst1 n b
- | LetIn (_, b, t, b') -> prod_app (subst1 b b') n
- | _ ->
- errorlabstrm "prod_app"
- (str"Needed a product, but didn't find one" ++ fnl ())
-
-
-(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
-let prod_applist t nL = List.fold_left prod_app t nL
-
-let replace_appvars subst =
- let rec aux c =
- let f, l = decompose_app c in
- if isVar f then
- try
- let c' = List.map (map_constr aux) l in
- let (t, b) = Id.List.assoc (destVar f) subst in
- mkApp (delayed_force hide_obligation,
- [| prod_applist t c'; applistc b c' |])
- with Not_found -> map_constr aux c
- else map_constr aux c
- in map_constr aux
-
-let subst_prog expand obls ints prg =
- let subst = obl_substitution expand obls ints in
- if get_hide_obligations () then
- (replace_appvars subst prg.prg_body,
- replace_appvars subst ((* Termops.refresh_universes *) prg.prg_type))
- else
- let subst' = List.map (fun (n, (_, b)) -> n, b) subst in
- (Vars.replace_vars subst' prg.prg_body,
- Vars.replace_vars subst' ((* Termops.refresh_universes *) prg.prg_type))
-
-let subst_deps_obl obls obl =
- let t' = subst_deps true obls obl.obl_deps obl.obl_type in
- { obl with obl_type = t' }
-
-module ProgMap = Id.Map
-
-let map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m)
-
-let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m []
-
-let from_prg : program_info ProgMap.t ref =
- Summary.ref ProgMap.empty ~name:"program-tcc-table"
-
-let close sec =
- if not (ProgMap.is_empty !from_prg) then
- let keys = map_keys !from_prg in
- errorlabstrm "Program"
- (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++
- prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++
- (str (if Int.equal (List.length keys) 1 then " has " else " have ") ++
- str "unsolved obligations"))
-
-let input : program_info ProgMap.t -> obj =
- declare_object
- { (default_object "Program state") with
- cache_function = (fun (na, pi) -> from_prg := pi);
- load_function = (fun _ (_, pi) -> from_prg := pi);
- discharge_function = (fun _ -> close "section"; None);
- classify_function = (fun _ -> close "module"; Dispose) }
-
-open Evd
-
-let progmap_remove prg =
- Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg))
-
-let progmap_add n prg =
- Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg))
-
-let progmap_replace prg' =
- Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg))
-
-let rec intset_to = function
- -1 -> Int.Set.empty
- | n -> Int.Set.add n (intset_to (pred n))
-
-let subst_body expand prg =
- let obls, _ = prg.prg_obligations in
- let ints = intset_to (pred (Array.length obls)) in
- subst_prog expand obls ints prg
-
-let declare_definition prg =
- let body, typ = subst_body true prg in
- let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None)
- (Evd.evar_universe_context_subst prg.prg_ctx) in
- let opaque = prg.prg_opaque in
- let fix_exn = Stm.get_fix_exn () in
- let pl, ctx =
- Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in
- let ce =
- definition_entry ~fix_exn
- ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind)
- ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body)
- in
- let () = progmap_remove prg in
- let cst =
- !declare_definition_ref prg.prg_name
- prg.prg_kind ce prg.prg_implicits
- (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r))
- in
- Universes.register_universe_binders cst pl;
- cst
-
-open Pp
-
-let rec lam_index n t acc =
- match kind_of_term t with
- | Lambda (Name n', _, _) when Id.equal n n' ->
- acc
- | Lambda (_, _, b) ->
- lam_index n b (succ acc)
- | _ -> raise Not_found
-
-let compute_possible_guardness_evidences (n,_) fixbody fixtype =
- match n with
- | Some (loc, n) -> [lam_index n fixbody 0]
- | None ->
- (* If recursive argument was not given by user, we try all args.
- An earlier approach was to look only for inductive arguments,
- but doing it properly involves delta-reduction, and it finally
- doesn't seem to worth the effort (except for huge mutual
- fixpoints ?) *)
- let m = Termops.nb_prod fixtype in
- let ctx = fst (decompose_prod_n_assum m fixtype) in
- List.map_i (fun i _ -> i) 0 ctx
-
-let mk_proof c = ((c, Univ.ContextSet.empty), Safe_typing.empty_private_constants)
-
-let declare_mutual_definition l =
- let len = List.length l in
- let first = List.hd l in
- let fixdefs, fixtypes, fiximps =
- List.split3
- (List.map (fun x ->
- let subs, typ = (subst_body true x) in
- let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in
- let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in
- x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l)
- in
-(* let fixdefs = List.map reduce_fix fixdefs in *)
- let fixkind = Option.get first.prg_fixkind in
- let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in
- let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in
- let (local,poly,kind) = first.prg_kind in
- let fixnames = first.prg_deps in
- let opaque = first.prg_opaque in
- let kind = if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in
- let indexes, fixdecls =
- match fixkind with
- | IsFixpoint wfl ->
- let possible_indexes =
- List.map3 compute_possible_guardness_evidences
- wfl fixdefs fixtypes in
- let indexes =
- Pretyping.search_guard
- Loc.ghost (Global.env())
- possible_indexes fixdecls in
- Some indexes,
- List.map_i (fun i _ ->
- mk_proof (mkFix ((indexes,i),fixdecls))) 0 l
- | IsCoFixpoint ->
- None,
- List.map_i (fun i _ ->
- mk_proof (mkCoFix (i,fixdecls))) 0 l
- in
- (* Declare the recursive definitions *)
- let ctx = Evd.evar_context_universe_context first.prg_ctx in
- let fix_exn = Stm.get_fix_exn () in
- let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx)
- fixnames fixdecls fixtypes fiximps in
- (* Declare notations *)
- List.iter Metasyntax.add_notation_interpretation 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
- Lemmas.call_hook fix_exn first.prg_hook local gr first.prg_ctx;
- List.iter progmap_remove l; kn
-
-let decompose_lam_prod c ty =
- let open Context.Rel.Declaration in
- let rec aux ctx c ty =
- match kind_of_term c, kind_of_term ty with
- | LetIn (x, b, t, c), LetIn (x', b', t', ty)
- when eq_constr b b' && eq_constr t t' ->
- let ctx' = Context.Rel.add (LocalDef (x,b',t')) ctx in
- aux ctx' c ty
- | _, LetIn (x', b', t', ty) ->
- let ctx' = Context.Rel.add (LocalDef (x',b',t')) ctx in
- aux ctx' (lift 1 c) ty
- | LetIn (x, b, t, c), _ ->
- let ctx' = Context.Rel.add (LocalDef (x,b,t)) ctx in
- aux ctx' c (lift 1 ty)
- | Lambda (x, b, t), Prod (x', b', t')
- (* By invariant, must be convertible *) ->
- let ctx' = Context.Rel.add (LocalAssum (x,b')) ctx in
- aux ctx' t t'
- | Cast (c, _, _), _ -> aux ctx c ty
- | _, _ -> ctx, c, ty
- in aux Context.Rel.empty c ty
-
-let shrink_body c ty =
- let open Context.Rel.Declaration in
- let ctx, b, ty =
- match ty with
- | None ->
- let ctx, b = decompose_lam_assum c in
- ctx, b, None
- | Some ty ->
- let ctx, b, ty = decompose_lam_prod c ty in
- ctx, b, Some ty
- in
- let b', ty', n, args =
- List.fold_left (fun (b, ty, i, args) decl ->
- if noccurn 1 b && Option.cata (noccurn 1) true ty then
- subst1 mkProp b, Option.map (subst1 mkProp) ty, succ i, args
- else
- let args = if is_local_assum decl then mkRel i :: args else args in
- mkLambda_or_LetIn decl b, Option.map (mkProd_or_LetIn decl) ty,
- succ i, args)
- (b, ty, 1, []) ctx
- in ctx, b', ty', Array.of_list args
-
-let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst]
-
-let add_hint local prg cst =
- Hints.add_hints local [Id.to_string prg.prg_name] (unfold_entry cst)
-
-let declare_obligation prg obl body ty uctx =
- let body = prg.prg_reduce body in
- let ty = Option.map prg.prg_reduce ty in
- match obl.obl_status with
- | _, Evar_kinds.Expand -> false, { obl with obl_body = Some (TermObl body) }
- | force, Evar_kinds.Define opaque ->
- let opaque = not force && opaque in
- let poly = pi2 prg.prg_kind in
- let ctx, body, ty, args =
- if get_shrink_obligations () && not poly then
- shrink_body body ty else [], body, ty, [||]
- in
- let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in
- let ce =
- { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body;
- const_entry_secctx = None;
- const_entry_type = ty;
- const_entry_polymorphic = poly;
- const_entry_universes = uctx;
- const_entry_opaque = opaque;
- const_entry_inline_code = false;
- const_entry_feedback = None;
- } in
- (** ppedrot: seems legit to have obligations as local *)
- let constant = Declare.declare_constant obl.obl_name ~local:true
- (DefinitionEntry ce,IsProof Property)
- in
- if not opaque then add_hint false prg constant;
- definition_message obl.obl_name;
- true, { obl with obl_body =
- if poly then
- Some (DefinedObl constant)
- else
- Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) }
-
-let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind
- notations obls impls kind reduce hook =
- let obls', b =
- match b with
- | None ->
- assert(Int.equal (Array.length obls) 0);
- let n = Nameops.add_suffix n "_obligation" in
- [| { obl_name = n; obl_body = None;
- obl_location = Loc.ghost, Evar_kinds.InternalHole; obl_type = t;
- obl_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty;
- obl_tac = None } |],
- mkVar n
- | Some b ->
- Array.mapi
- (fun i (n, t, l, o, d, tac) ->
- { obl_name = n ; obl_body = None;
- obl_location = l; obl_type = t; obl_status = o;
- obl_deps = d; obl_tac = tac })
- obls, b
- in
- { prg_name = n ; prg_body = b; prg_type = reduce t;
- prg_ctx = ctx; prg_pl = pl;
- prg_obligations = (obls', Array.length obls');
- prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
- prg_implicits = impls; prg_kind = kind; prg_reduce = reduce;
- prg_hook = hook; prg_opaque = opaque;
- prg_sign = sign }
-
-let map_cardinal m =
- let i = ref 0 in
- ProgMap.iter (fun _ v ->
- if snd (CEphemeron.get v).prg_obligations > 0 then incr i) m;
- !i
-
-exception Found of program_info
-
-let map_first m =
- try
- ProgMap.iter (fun _ v ->
- if snd (CEphemeron.get v).prg_obligations > 0 then
- raise (Found v)) m;
- assert(false)
- with Found x -> x
-
-let get_prog name =
- let prg_infos = !from_prg in
- match name with
- Some n ->
- (try get_info (ProgMap.find n prg_infos)
- with Not_found -> raise (NoObligations (Some n)))
- | None ->
- (let n = map_cardinal prg_infos in
- match n with
- 0 -> raise (NoObligations None)
- | 1 -> get_info (map_first prg_infos)
- | _ ->
- let progs = Id.Set.elements (ProgMap.domain prg_infos) in
- let prog = List.hd progs in
- let progs = prlist_with_sep pr_comma Nameops.pr_id progs in
- errorlabstrm ""
- (str "More than one program with unsolved obligations: " ++ progs
- ++ str "; use the \"of\" clause to specify, as in \"Obligation 1 of " ++ Nameops.pr_id prog ++ str "\""))
-
-let get_any_prog () =
- let prg_infos = !from_prg in
- let n = map_cardinal prg_infos in
- if n > 0 then get_info (map_first prg_infos)
- else raise (NoObligations None)
-
-let get_prog_err n =
- try get_prog n with NoObligations id -> pperror (explain_no_obligations id)
-
-let get_any_prog_err () =
- try get_any_prog () with NoObligations id -> pperror (explain_no_obligations id)
-
-let obligations_solved prg = Int.equal (snd prg.prg_obligations) 0
-
-let all_programs () =
- ProgMap.fold (fun k p l -> p :: l) !from_prg []
-
-type progress =
- | Remain of int
- | Dependent
- | Defined of global_reference
-
-let obligations_message rem =
- if rem > 0 then
- if Int.equal rem 1 then
- Flags.if_verbose Feedback.msg_info (int rem ++ str " obligation remaining")
- else
- Flags.if_verbose Feedback.msg_info (int rem ++ str " obligations remaining")
- else
- Flags.if_verbose Feedback.msg_info (str "No more obligations remaining")
-
-let update_obls prg obls rem =
- let prg' = { prg with prg_obligations = (obls, rem) } in
- progmap_replace prg';
- obligations_message rem;
- if rem > 0 then Remain rem
- else (
- match prg'.prg_deps with
- | [] ->
- let kn = declare_definition prg' in
- progmap_remove prg';
- Defined kn
- | l ->
- let progs = List.map (fun x -> get_info (ProgMap.find x !from_prg)) prg'.prg_deps in
- if List.for_all (fun x -> obligations_solved x) progs then
- let kn = declare_mutual_definition progs in
- Defined (ConstRef kn)
- else Dependent)
-
-let is_defined obls x = not (Option.is_empty obls.(x).obl_body)
-
-let deps_remaining obls deps =
- Int.Set.fold
- (fun x acc ->
- if is_defined obls x then acc
- else x :: acc)
- deps []
-
-let dependencies obls n =
- let res = ref Int.Set.empty in
- Array.iteri
- (fun i obl ->
- if not (Int.equal i n) && Int.Set.mem n obl.obl_deps then
- res := Int.Set.add i !res)
- obls;
- !res
-
-let goal_kind poly = Decl_kinds.Local, poly, Decl_kinds.DefinitionBody Decl_kinds.Definition
-
-let goal_proof_kind poly = Decl_kinds.Local, poly, Decl_kinds.Proof Decl_kinds.Lemma
-
-let kind_of_obligation poly o =
- match o with
- | Evar_kinds.Define false | Evar_kinds.Expand -> goal_kind poly
- | _ -> goal_proof_kind poly
-
-let not_transp_msg =
- str "Obligation should be transparent but was declared opaque." ++ spc () ++
- str"Use 'Defined' instead."
-
-let err_not_transp () = pperror not_transp_msg
-
-let rec string_of_list sep f = function
- [] -> ""
- | x :: [] -> f x
- | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
-
-(* Solve an obligation using tactics, return the corresponding proof term *)
-
-let solve_by_tac name evi t poly ctx =
- let id = name in
- let concl = evi.evar_concl in
- (* spiwack: the status is dropped. *)
- let (entry,_,ctx') = Pfedit.build_constant_by_tactic
- id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps concl (Tacticals.New.tclCOMPLETE t) in
- let env = Global.env () in
- let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in
- let body, eff = Future.force entry.const_entry_body in
- assert(Safe_typing.empty_private_constants = eff);
- let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in
- Inductiveops.control_only_guard (Global.env ()) (fst body);
- (fst body), entry.const_entry_type, Evd.evar_universe_context ctx'
-
-let obligation_terminator name num guard hook auto pf =
- let open Proof_global in
- let term = Lemmas.universe_proof_terminator guard hook in
- match pf with
- | Admitted _ -> apply_terminator term pf
- | Proved (opq, id, proof) ->
- if not !shrink_obligations then apply_terminator term pf
- else
- let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in
- let env = Global.env () in
- let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in
- let ty = entry.Entries.const_entry_type in
- let (body, cstr), eff = Future.force entry.Entries.const_entry_body in
- assert(Safe_typing.empty_private_constants = eff);
- let sigma = Evd.from_ctx (fst uctx) in
- let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in
- Inductiveops.control_only_guard (Global.env ()) body;
- (** Declare the obligation ourselves and drop the hook *)
- let prg = get_info (ProgMap.find name !from_prg) in
- let ctx = Evd.evar_universe_context sigma in
- let prg = { prg with prg_ctx = ctx } in
- let obls, rem = prg.prg_obligations in
- 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.Define true), Vernacexpr.Transparent -> Evar_kinds.Define false
- | (_, status), Vernacexpr.Transparent -> status
- in
- let obl = { obl with obl_status = false, status } in
- let uctx = Evd.evar_context_universe_context ctx in
- let (_, obl) = declare_obligation prg obl body ty uctx in
- let obls = Array.copy obls in
- let _ = obls.(num) <- obl in
- try
- ignore (update_obls prg obls (pred rem));
- if pred rem > 0 then
- begin
- let deps = dependencies obls num in
- if not (Int.Set.is_empty deps) then
- ignore (auto (Some name) None deps)
- end
- with e when CErrors.noncritical e ->
- let e = CErrors.push e in
- pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e))
-
-let obligation_hook prg obl num auto ctx' _ gr =
- let obls, rem = prg.prg_obligations in
- let cst = match gr with ConstRef cst -> cst | _ -> assert false in
- let transparent = evaluable_constant cst (Global.env ()) in
- let () = match obl.obl_status with
- (true, Evar_kinds.Expand)
- | (true, Evar_kinds.Define true) ->
- if not transparent then err_not_transp ()
- | _ -> ()
-in
- let obl = { obl with obl_body = Some (DefinedObl cst) } in
- let () = if transparent then add_hint true prg cst in
- let obls = Array.copy obls in
- let _ = obls.(num) <- obl in
- let ctx' = match ctx' with None -> prg.prg_ctx | Some ctx' -> ctx' in
- let ctx' =
- if not (pi2 prg.prg_kind) (* Not polymorphic *) then
- (* The universe context was declared globally, we continue
- from the new global environment. *)
- let evd = Evd.from_env (Global.env ()) in
- let ctx' = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx')) in
- Evd.evar_universe_context ctx'
- else ctx'
- in
- let prg = { prg with prg_ctx = ctx' } in
- let () =
- try ignore (update_obls prg obls (pred rem))
- with e when CErrors.noncritical e ->
- let e = CErrors.push e in
- pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e))
- in
- if pred rem > 0 then begin
- let deps = dependencies obls num in
- if not (Int.Set.is_empty deps) then
- ignore (auto (Some prg.prg_name) None deps)
- end
-
-let rec solve_obligation prg num tac =
- let user_num = succ num in
- let obls, rem = prg.prg_obligations in
- let obl = obls.(num) in
- let remaining = deps_remaining obls obl.obl_deps in
- let () =
- if not (Option.is_empty obl.obl_body) then
- pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.");
- if not (List.is_empty remaining) then
- pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
- ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) remaining));
- in
- let obl = subst_deps_obl obls obl in
- let kind = kind_of_obligation (pi2 prg.prg_kind) (snd obl.obl_status) in
- let evd = Evd.from_ctx prg.prg_ctx in
- let evd = Evd.update_sigma_env evd (Global.env ()) in
- let auto n tac oblset = auto_solve_obligations n ~oblset tac in
- let terminator guard hook =
- Proof_global.make_terminator
- (obligation_terminator prg.prg_name num guard hook auto) in
- let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in
- let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd obl.obl_type ~terminator hook in
- let _ = Pfedit.by !default_tactic in
- Option.iter (fun tac -> Pfedit.set_end_tac tac) tac
-
-and obligation (user_num, name, typ) tac =
- let num = pred user_num in
- let prg = get_prog_err name in
- let obls, rem = prg.prg_obligations in
- if num < Array.length obls then
- let obl = obls.(num) in
- match obl.obl_body with
- None -> solve_obligation prg num tac
- | Some r -> error "Obligation already solved"
- else error (sprintf "Unknown obligation number %i" (succ num))
-
-
-and solve_obligation_by_tac prg obls i tac =
- let obl = obls.(i) in
- match obl.obl_body with
- | Some _ -> None
- | None ->
- try
- if List.is_empty (deps_remaining obls obl.obl_deps) then
- let obl = subst_deps_obl obls obl in
- let tac =
- match tac with
- | Some t -> t
- | None ->
- match obl.obl_tac with
- | Some t -> t
- | None -> !default_tactic
- in
- let evd = Evd.from_ctx prg.prg_ctx in
- let evd = Evd.update_sigma_env evd (Global.env ()) in
- let t, ty, ctx =
- solve_by_tac obl.obl_name (evar_of_obligation obl) tac
- (pi2 prg.prg_kind) (Evd.evar_universe_context evd)
- in
- let uctx = Evd.evar_context_universe_context ctx in
- let prg = {prg with prg_ctx = ctx} in
- let def, obl' = declare_obligation prg obl t ty uctx in
- obls.(i) <- obl';
- if def && not (pi2 prg.prg_kind) then (
- (* Declare the term constraints with the first obligation only *)
- let evd = Evd.from_env (Global.env ()) in
- let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in
- let ctx' = Evd.evar_universe_context evd in
- Some {prg with prg_ctx = ctx'})
- else Some prg
- else None
- with e when CErrors.noncritical e ->
- let (e, _) = CErrors.push e in
- match e with
- | Refiner.FailError (_, s) ->
- user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s)
- | e -> None (* FIXME really ? *)
-
-and solve_prg_obligations prg ?oblset tac =
- let obls, rem = prg.prg_obligations in
- let rem = ref rem in
- let obls' = Array.copy obls in
- let set = ref Int.Set.empty in
- let p = match oblset with
- | None -> (fun _ -> true)
- | Some s -> set := s;
- (fun i -> Int.Set.mem i !set)
- in
- let prgref = ref prg in
- let _ =
- Array.iteri (fun i x ->
- if p i then
- match solve_obligation_by_tac !prgref obls' i tac with
- | None -> ()
- | Some prg' ->
- prgref := prg';
- let deps = dependencies obls i in
- (set := Int.Set.union !set deps;
- decr rem))
- obls'
- in
- update_obls !prgref obls' !rem
-
-and solve_obligations n tac =
- let prg = get_prog_err n in
- solve_prg_obligations prg tac
-
-and solve_all_obligations tac =
- ProgMap.iter (fun k v -> ignore(solve_prg_obligations (get_info v) tac)) !from_prg
-
-and try_solve_obligation n prg tac =
- let prg = get_prog prg in
- let obls, rem = prg.prg_obligations in
- let obls' = Array.copy obls in
- match solve_obligation_by_tac prg obls' n tac with
- | Some prg' -> ignore(update_obls prg' obls' (pred rem))
- | None -> ()
-
-and try_solve_obligations n tac =
- try ignore (solve_obligations n tac) with NoObligations _ -> ()
-
-and auto_solve_obligations n ?oblset tac : progress =
- Flags.if_verbose Feedback.msg_info (str "Solving obligations automatically...");
- try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent
-
-open Pp
-let show_obligations_of_prg ?(msg=true) prg =
- let n = prg.prg_name in
- let obls, rem = prg.prg_obligations in
- let showed = ref 5 in
- if msg then Feedback.msg_info (int rem ++ str " obligation(s) remaining: ");
- Array.iteri (fun i x ->
- match x.obl_body with
- | None ->
- if !showed > 0 then (
- decr showed;
- let x = subst_deps_obl obls x in
- Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++
- str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++
- hov 1 (Printer.pr_constr_env (Global.env ()) Evd.empty x.obl_type ++
- str "." ++ fnl ())))
- | Some _ -> ())
- obls
-
-let show_obligations ?(msg=true) n =
- let progs = match n with
- | None -> all_programs ()
- | Some n ->
- try [ProgMap.find n !from_prg]
- with Not_found -> raise (NoObligations (Some n))
- in List.iter (fun x -> show_obligations_of_prg ~msg (get_info x)) progs
-
-let show_term n =
- let prg = get_prog_err n in
- let n = prg.prg_name in
- (Id.print n ++ spc () ++ str":" ++ spc () ++
- 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
- ?(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 obls,_ = prg.prg_obligations in
- if Int.equal (Array.length obls) 0 then (
- Flags.if_verbose Feedback.msg_info (info ++ str ".");
- let cst = declare_definition prg in
- Defined cst)
- else (
- let len = Array.length obls in
- let _ = Flags.if_verbose Feedback.msg_info (info ++ str ", generating " ++ int len ++ str " obligation(s)") in
- progmap_add n (CEphemeron.create prg);
- let res = auto_solve_obligations (Some n) tactic in
- match res with
- | 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)
- ?(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)
- notations obls imps kind reduce hook
- in progmap_add n (CEphemeron.create prg)) l;
- let _defined =
- List.fold_left (fun finished x ->
- if finished then finished
- else
- let res = auto_solve_obligations (Some x) tactic in
- match res with
- | Defined _ ->
- (* If one definition is turned into a constant,
- the whole block is defined. *) true
- | _ -> false)
- false deps
- in ()
-
-let admit_prog prg =
- let obls, rem = prg.prg_obligations in
- let obls = Array.copy obls in
- Array.iteri
- (fun i x ->
- match x.obl_body with
- | None ->
- let x = subst_deps_obl obls x in
- let ctx = Evd.evar_context_universe_context prg.prg_ctx in
- let kn = Declare.declare_constant x.obl_name ~local:true
- (ParameterEntry (None,false,(x.obl_type,ctx),None), IsAssumption Conjectural)
- in
- assumption_message x.obl_name;
- obls.(i) <- { x with obl_body = Some (DefinedObl kn) }
- | Some _ -> ())
- obls;
- ignore(update_obls prg obls 0)
-
-let rec admit_all_obligations () =
- let prg = try Some (get_any_prog ()) with NoObligations _ -> None in
- match prg with
- | None -> ()
- | Some prg ->
- admit_prog prg;
- admit_all_obligations ()
-
-let admit_obligations n =
- match n with
- | None -> admit_all_obligations ()
- | Some _ ->
- let prg = get_prog_err n in
- admit_prog prg
-
-let next_obligation n tac =
- let prg = match n with
- | None -> get_any_prog_err ()
- | Some _ -> get_prog_err n
- in
- let obls, rem = prg.prg_obligations in
- let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in
- let i = match Array.findi is_open obls with
- | Some i -> i
- | None -> anomaly (Pp.str "Could not find a solvable obligation.")
- in
- solve_obligation prg i tac
-
-let init_program () =
- Coqlib.check_required_library Coqlib.datatypes_module_name;
- Coqlib.check_required_library ["Coq";"Init";"Specif"];
- Coqlib.check_required_library ["Coq";"Program";"Tactics"]
-
-
-let set_program_mode c =
- if c then
- if !Flags.program_mode then ()
- else begin
- init_program ();
- Flags.program_mode := true;
- end
diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli
deleted file mode 100644
index 69d20696..00000000
--- a/toplevel/obligations.mli
+++ /dev/null
@@ -1,113 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Environ
-open Term
-open Evd
-open Names
-open Pp
-open Globnames
-open Vernacexpr
-open Decl_kinds
-
-(** Forward declaration. *)
-val declare_fix_ref : (?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t ->
- Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref
-
-val declare_definition_ref :
- (Id.t -> definition_kind ->
- Safe_typing.private_constants Entries.definition_entry -> Impargs.manual_implicits
- -> global_reference Lemmas.declaration_hook -> global_reference) ref
-
-val check_evars : env -> evar_map -> unit
-
-val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t
-val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar_info * Evar.Set.t) list
-
-(* env, id, evars, number of function prototypes to try to clear from
- evars contexts, object and type *)
-val eterm_obligations : env -> Id.t -> evar_map -> int ->
- ?status:Evar_kinds.obligation_definition_status -> constr -> types ->
- (Id.t * types * Evar_kinds.t Loc.located *
- (bool * Evar_kinds.obligation_definition_status) * Int.Set.t *
- unit Proofview.tactic option) array
- (* Existential key, obl. name, type as product,
- location of the original evar, associated tactic,
- status and dependencies as indexes into the array *)
- * ((existential_key * Id.t) list * ((Id.t -> constr) -> constr -> constr)) *
- constr * types
- (* Translations from existential identifiers to obligation identifiers
- and for terms with existentials to closed terms, given a
- translation from obligation identifiers to constrs, new term, new type *)
-
-type obligation_info =
- (Id.t * Term.types * Evar_kinds.t Loc.located *
- (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array
- (* ident, type, location, (opaque or transparent, expand or define),
- dependencies, tactic to solve it *)
-
-type progress = (* Resolution status of a program *)
- | Remain of int (* n obligations remaining *)
- | Dependent (* Dependent on other definitions *)
- | Defined of global_reference (* Defined as id *)
-
-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 *)
- ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list ->
- ?kind:Decl_kinds.definition_kind ->
- ?tactic:unit Proofview.tactic ->
- ?reduce:(Term.constr -> Term.constr) ->
- ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress
-
-type notations =
- (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list
-
-type fixpoint_kind =
- | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list
- | IsCoFixpoint
-
-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 *)
- ?tactic:unit Proofview.tactic ->
- ?kind:Decl_kinds.definition_kind ->
- ?reduce:(Term.constr -> Term.constr) ->
- ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool ->
- notations ->
- fixpoint_kind -> unit
-
-val obligation : int * Names.Id.t option * Constrexpr.constr_expr option ->
- Tacexpr.raw_tactic_expr option -> unit
-
-val next_obligation : Names.Id.t option -> Tacexpr.raw_tactic_expr option -> unit
-
-val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress
-(* Number of remaining obligations to be solved for this program *)
-
-val solve_all_obligations : unit Proofview.tactic option -> unit
-
-val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit
-
-val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit
-
-val show_obligations : ?msg:bool -> Names.Id.t option -> unit
-
-val show_term : Names.Id.t option -> std_ppcmds
-
-val admit_obligations : Names.Id.t option -> unit
-
-exception NoObligations of Names.Id.t option
-
-val explain_no_obligations : Names.Id.t option -> Pp.std_ppcmds
-
-val set_program_mode : bool -> unit
diff --git a/toplevel/record.ml b/toplevel/record.ml
deleted file mode 100644
index ef09f6fa..00000000
--- a/toplevel/record.ml
+++ /dev/null
@@ -1,579 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open CErrors
-open Util
-open Names
-open Globnames
-open Nameops
-open Term
-open Vars
-open Environ
-open Declarations
-open Entries
-open Declare
-open Constrintern
-open Decl_kinds
-open Type_errors
-open Constrexpr
-open Constrexpr_ops
-open Goptions
-open Sigma.Notations
-open Context.Rel.Declaration
-
-(********** definition d'un record (structure) **************)
-
-(** Flag governing use of primitive projections. Disabled by default. *)
-let primitive_flag = ref false
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "use of primitive projections";
- optkey = ["Primitive";"Projections"];
- optread = (fun () -> !primitive_flag) ;
- optwrite = (fun b -> primitive_flag := b) }
-
-let typeclasses_strict = ref false
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "strict typeclass resolution";
- optkey = ["Typeclasses";"Strict";"Resolution"];
- optread = (fun () -> !typeclasses_strict);
- optwrite = (fun b -> typeclasses_strict := b); }
-
-let typeclasses_unique = ref false
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "unique typeclass instances";
- optkey = ["Typeclasses";"Unique";"Instances"];
- optread = (fun () -> !typeclasses_unique);
- optwrite = (fun b -> typeclasses_unique := b); }
-
-let interp_fields_evars env evars impls_env nots l =
- List.fold_left2
- (fun (env, uimpls, params, impls) no ((loc, i), b, t) ->
- let t', impl = interp_type_evars_impls env evars ~impls t in
- let b' = Option.map (fun x -> fst (interp_casted_constr_evars_impls env evars ~impls x t')) b in
- let impls =
- match i with
- | Anonymous -> impls
- | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method t' impl) impls
- in
- let d = match b' with
- | None -> LocalAssum (i,t')
- | Some b' -> LocalDef (i,b',t')
- in
- List.iter (Metasyntax.set_notation_for_interpretation impls) no;
- (push_rel d env, impl :: uimpls, d::params, impls))
- (env, [], [], impls_env) nots l
-
-let compute_constructor_level evars env l =
- List.fold_right (fun d (env, univ) ->
- let univ =
- if is_local_assum d then
- let s = Retyping.get_sort_of env evars (get_type d) in
- Univ.sup (univ_of_sort s) univ
- else univ
- in (push_rel d env, univ))
- l (env, Univ.type0m_univ)
-
-let binder_of_decl = function
- | Vernacexpr.AssumExpr(n,t) -> (n,None,t)
- | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c | None -> CHole (fst n, None, Misctypes.IntroAnonymous, None))
-
-let binders_of_decls = List.map binder_of_decl
-
-let typecheck_params_and_fields 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 _ =
- let error bk (loc, name) =
- match bk, name with
- | Default _, Anonymous ->
- user_err_loc (loc, "record", str "Record parameters must be named")
- | _ -> ()
- in
- List.iter
- (function LocalRawDef (b, _) -> error default_binder_kind b
- | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls
- | LocalPattern _ -> assert false) ps
- in
- let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in
- let t', template = match t with
- | Some t ->
- let env = push_rel_context newps env0 in
- let poly =
- match t with
- | CSort (_, Misctypes.GType []) -> true | _ -> false in
- let s = interp_type_evars env evars ~impls:empty_internalization_env t in
- let sred = Reductionops.whd_all env !evars s in
- (match kind_of_term sred with
- | Sort s' ->
- (if poly then
- match Evd.is_sort_variable !evars s' with
- | Some l -> evars := Evd.make_flexible_variable !evars true l;
- sred, true
- | None -> s, false
- else s, false)
- | _ -> user_err_loc (constr_loc t,"", str"Sort expected."))
- | None ->
- let uvarkind = Evd.univ_flexible_alg in
- mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), true
- in
- let fullarity = it_mkProd_or_LetIn t' newps in
- let env_ar = push_rel_context newps (push_rel (LocalAssum (Name id,fullarity)) env0) in
- let env2,impls,newfs,data =
- interp_fields_evars env_ar evars impls_env nots (binders_of_decls fs)
- in
- let sigma =
- Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar !evars (Evd.empty,!evars) in
- let evars, nf = Evarutil.nf_evars_and_universes sigma in
- let arity = nf t' in
- let arity, evars =
- let _, univ = compute_constructor_level evars env_ar newfs in
- let ctx, aritysort = Reduction.dest_arity env0 arity in
- assert(List.is_empty ctx); (* Ensured by above analysis *)
- if not def && (Sorts.is_prop aritysort ||
- (Sorts.is_set aritysort && is_impredicative_set env0)) then
- arity, evars
- else
- let evars = Evd.set_leq_sort env_ar evars (Type univ) aritysort in
- if Univ.is_small_univ univ &&
- Option.cata (Evd.is_flexible_level evars) false (Evd.is_sort_variable evars aritysort) then
- (* We can assume that the level in aritysort is not constrained
- and clear it, if it is flexible *)
- mkArity (ctx, Sorts.sort_of_univ univ),
- Evd.set_eq_sort env_ar evars (Prop Pos) aritysort
- else arity, evars
- in
- let evars, nf = Evarutil.nf_evars_and_universes evars in
- let newps = Context.Rel.map nf newps in
- let newfs = Context.Rel.map nf newfs in
- let ce t = Pretyping.check_evars env0 Evd.empty evars t in
- List.iter (iter_constr ce) (List.rev newps);
- List.iter (iter_constr ce) (List.rev newfs);
- Evd.universe_context ?names:pl evars, nf arity, template, imps, newps, impls, newfs
-
-let degenerate_decl decl =
- let id = match get_name decl with
- | Name id -> id
- | Anonymous -> anomaly (Pp.str "Unnamed record variable") in
- match decl with
- | LocalAssum (_,t) -> (id, LocalAssumEntry t)
- | LocalDef (_,b,_) -> (id, LocalDefEntry b)
-
-type record_error =
- | MissingProj of Id.t * Id.t list
- | BadTypedProj of Id.t * env * Type_errors.type_error
-
-let warn_cannot_define_projection =
- CWarnings.create ~name:"cannot-define-projection" ~category:"records"
- (fun msg -> hov 0 msg)
-
-(* If a projection is not definable, we throw an error if the user
-asked it to be a coercion. Otherwise, we just print an info
-message. The user might still want to name the field of the record. *)
-let warning_or_error coe indsp err =
- let st = match err with
- | MissingProj (fi,projs) ->
- let s,have = if List.length projs > 1 then "s","were" else "","was" in
- (pr_id fi ++
- strbrk" cannot be defined because the projection" ++ str s ++ spc () ++
- prlist_with_sep pr_comma pr_id projs ++ spc () ++ str have ++
- strbrk " not defined.")
- | BadTypedProj (fi,ctx,te) ->
- match te with
- | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) ->
- (pr_id fi ++
- strbrk" cannot be defined because it is informative and " ++
- Printer.pr_inductive (Global.env()) indsp ++
- strbrk " is not.")
- | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) ->
- (pr_id fi ++
- strbrk" cannot be defined because it is large and " ++
- Printer.pr_inductive (Global.env()) indsp ++
- strbrk " is not.")
- | _ ->
- (pr_id fi ++ strbrk " cannot be defined because it is not typable.")
- in
- if coe then errorlabstrm "structure" st;
- Flags.if_verbose Feedback.msg_info (hov 0 st)
-
-type field_status =
- | NoProjection of Name.t
- | Projection of constr
-
-exception NotDefinable of record_error
-
-(* This replaces previous projection bodies in current projection *)
-(* Undefined projs are collected and, at least one undefined proj occurs *)
-(* in the body of current projection then the latter can not be defined *)
-(* [c] is defined in ctxt [[params;fields]] and [l] is an instance of *)
-(* [[fields]] defined in ctxt [[params;x:ind]] *)
-let subst_projection fid l c =
- let lv = List.length l in
- let bad_projs = ref [] in
- let rec substrec depth c = match kind_of_term c with
- | Rel k ->
- (* We are in context [[params;fields;x:ind;...depth...]] *)
- if k <= depth+1 then
- c
- else if k-depth-1 <= lv then
- match List.nth l (k-depth-2) with
- | Projection t -> lift depth t
- | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k
- | NoProjection Anonymous ->
- errorlabstrm "" (str "Field " ++ pr_id fid ++
- str " depends on the " ++ pr_nth (k-depth-1) ++ str
- " field which has no name.")
- else
- mkRel (k-lv)
- | _ -> map_constr_with_binders succ substrec depth c
- in
- let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *)
- let c'' = substrec 0 c' in
- if not (List.is_empty !bad_projs) then
- raise (NotDefinable (MissingProj (fid,List.rev !bad_projs)));
- c''
-
-let instantiate_possibly_recursive_type indu paramdecls fields =
- let subst = List.map_i (fun i _ -> mkRel i) 1 paramdecls in
- Termops.substl_rel_context (subst@[mkIndU indu]) fields
-
-let warn_non_primitive_record =
- CWarnings.create ~name:"non-primitive-record" ~category:"record"
- (fun (env,indsp) ->
- (hov 0 (str "The record " ++ Printer.pr_inductive env indsp ++
- strbrk" could not be defined as a primitive record")))
-
-(* We build projections *)
-let declare_projections indsp ?(kind=StructureComponent) binder_name coers fieldimpls fields =
- let env = Global.env() in
- let (mib,mip) = Global.lookup_inductive indsp in
- let u = Declareops.inductive_instance mib in
- let paramdecls = Inductive.inductive_paramdecls (mib, u) in
- let poly = mib.mind_polymorphic in
- let ctx = Univ.instantiate_univ_context mib.mind_universes in
- let indu = indsp, u in
- let r = mkIndU (indsp,u) in
- let rp = applist (r, Context.Rel.to_extended_list 0 paramdecls) in
- let paramargs = Context.Rel.to_extended_list 1 paramdecls in (*def in [[params;x:rp]]*)
- let x = Name binder_name in
- let fields = instantiate_possibly_recursive_type indu paramdecls fields in
- let lifted_fields = Termops.lift_rel_context 1 fields in
- let primitive =
- if !primitive_flag then
- let is_primitive =
- match mib.mind_record with
- | Some (Some _) -> true
- | Some None | None -> false
- in
- if not is_primitive then
- warn_non_primitive_record (env,indsp);
- is_primitive
- else false
- in
- let (_,_,kinds,sp_projs,_) =
- List.fold_left3
- (fun (nfi,i,kinds,sp_projs,subst) coe decl impls ->
- let fi = get_name decl in
- let ti = get_type decl in
- let (sp_projs,i,subst) =
- match fi with
- | Anonymous ->
- (None::sp_projs,i,NoProjection fi::subst)
- | Name fid -> try
- let kn, term =
- if is_local_assum decl && primitive then
- (** Already defined in the kernel silently *)
- let kn = destConstRef (Nametab.locate (Libnames.qualid_of_ident fid)) in
- Declare.definition_message fid;
- kn, mkProj (Projection.make kn false,mkRel 1)
- else
- let ccl = subst_projection fid subst ti in
- let body = match decl with
- | LocalDef (_,ci,_) -> subst_projection fid subst ci
- | LocalAssum _ ->
- (* [ccl] is defined in context [params;x:rp] *)
- (* [ccl'] is defined in context [params;x:rp;x:rp] *)
- let ccl' = liftn 1 2 ccl in
- let p = mkLambda (x, lift 1 rp, ccl') in
- let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in
- let ci = Inductiveops.make_case_info env indsp LetStyle in
- mkCase (ci, p, mkRel 1, [|branch|])
- in
- let proj =
- it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in
- let projtyp =
- it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in
- try
- let entry = {
- const_entry_body =
- Future.from_val (Safe_typing.mk_pure_proof proj);
- const_entry_secctx = None;
- const_entry_type = Some projtyp;
- const_entry_polymorphic = poly;
- const_entry_universes =
- if poly then ctx else Univ.UContext.empty;
- const_entry_opaque = false;
- const_entry_inline_code = false;
- const_entry_feedback = None } in
- let k = (DefinitionEntry entry,IsDefinition kind) in
- let kn = declare_constant ~internal:InternalTacticRequest fid k in
- let constr_fip =
- let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in
- applist (mkConstU (kn,u),proj_args)
- in
- Declare.definition_message fid;
- kn, constr_fip
- with Type_errors.TypeError (ctx,te) ->
- raise (NotDefinable (BadTypedProj (fid,ctx,te)))
- in
- let refi = ConstRef kn in
- Impargs.maybe_declare_manual_implicits false refi impls;
- if coe then begin
- let cl = Class.class_of_global (IndRef indsp) in
- Class.try_add_new_coercion_with_source refi ~local:false poly ~source:cl
- end;
- let i = if is_local_assum decl then i+1 else i in
- (Some kn::sp_projs, i, Projection term::subst)
- with NotDefinable why ->
- warning_or_error coe indsp why;
- (None::sp_projs,i,NoProjection fi::subst) in
- (nfi-1,i,(fi, is_local_assum decl)::kinds,sp_projs,subst))
- (List.length fields,0,[],[],[]) coers (List.rev fields) (List.rev fieldimpls)
- in (kinds,sp_projs)
-
-let structure_signature ctx =
- let rec deps_to_evar evm l =
- match l with [] -> Evd.empty
- | [decl] ->
- let env = Environ.empty_named_context_val in
- let evm = Sigma.Unsafe.of_evar_map evm in
- let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in
- let evm = Sigma.to_evar_map evm in
- evm
- | decl::tl ->
- let env = Environ.empty_named_context_val in
- let evm = Sigma.Unsafe.of_evar_map evm in
- let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in
- let evm = Sigma.to_evar_map evm in
- let new_tl = Util.List.map_i
- (fun pos decl ->
- map_type (fun t -> Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) decl) 1 tl in
- deps_to_evar evm new_tl in
- deps_to_evar Evd.empty (List.rev ctx)
-
-open Typeclasses
-
-let declare_structure finite poly ctx id idbuild paramimpls params arity template
- fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign =
- let nparams = List.length params and nfields = List.length fields in
- let args = Context.Rel.to_extended_list nfields params in
- let ind = applist (mkRel (1+nparams+nfields), args) in
- let type_constructor = it_mkProd_or_LetIn ind fields in
- let binder_name =
- match name with
- | None -> Id.of_string (Unicode.lowercase_first_char (Id.to_string id))
- | Some n -> n
- in
- let mie_ind =
- { mind_entry_typename = id;
- mind_entry_arity = arity;
- mind_entry_template = not poly && template;
- mind_entry_consnames = [idbuild];
- mind_entry_lc = [type_constructor] }
- in
- let mie =
- { mind_entry_params = List.map degenerate_decl params;
- mind_entry_record = Some (if !primitive_flag then Some binder_name else None);
- mind_entry_finite = finite;
- mind_entry_inds = [mie_ind];
- mind_entry_polymorphic = poly;
- mind_entry_private = None;
- mind_entry_universes = ctx;
- }
- in
- let kn = Command.declare_mutual_inductive_with_eliminations mie [] [(paramimpls,[])] in
- let rsp = (kn,0) in (* This is ind path of idstruc *)
- let cstr = (rsp,1) in
- let kinds,sp_projs = declare_projections rsp ~kind binder_name coers fieldimpls fields in
- let build = ConstructRef cstr in
- let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in
- Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs);
- rsp
-
-let implicits_of_context ctx =
- List.map_i (fun i name ->
- let explname =
- match name with
- | Name n -> Some n
- | Anonymous -> None
- in ExplByPos (i, explname), (true, true, true))
- 1 (List.rev (Anonymous :: (List.map get_name ctx)))
-
-let declare_class finite def poly ctx id idbuild paramimpls params arity
- template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign =
- let fieldimpls =
- (* Make the class implicit in the projections, and the params if applicable. *)
- let len = List.length params in
- 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 impl, projs =
- match fields with
- | [LocalAssum (Name proj_name, field) | LocalDef (Name proj_name, _, field)] when def ->
- let class_body = it_mkLambda_or_LetIn field params in
- let class_type = it_mkProd_or_LetIn arity params in
- let class_entry =
- Declare.definition_entry ~types:class_type ~poly ~univs:ctx class_body in
- let cst = Declare.declare_constant (snd id)
- (DefinitionEntry class_entry, IsDefinition Definition)
- in
- let cstu = (cst, if poly then Univ.UContext.instance ctx else Univ.Instance.empty) in
- let inst_type = appvectc (mkConstU cstu)
- (Termops.rel_vect 0 (List.length params)) in
- let proj_type =
- it_mkProd_or_LetIn (mkProd(Name binder_name, inst_type, lift 1 field)) params in
- let proj_body =
- it_mkLambda_or_LetIn (mkLambda (Name binder_name, inst_type, mkRel 1)) params in
- let proj_entry =
- Declare.definition_entry ~types:proj_type ~poly
- ~univs:(if poly then ctx else Univ.UContext.empty) proj_body
- in
- let proj_cst = Declare.declare_constant proj_name
- (DefinitionEntry proj_entry, IsDefinition Definition)
- in
- let cref = ConstRef cst in
- Impargs.declare_manual_implicits false cref [paramimpls];
- Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls];
- Classes.set_typeclass_transparency (EvalConstRef cst) false false;
- let sub = match List.hd coers with
- | Some b -> Some ((if b then Backward else Forward), List.hd priorities)
- | None -> None
- in
- cref, [Name proj_name, sub, Some proj_cst]
- | _ ->
- let ind = declare_structure BiFinite poly ctx (snd id) idbuild paramimpls
- params arity template fieldimpls fields
- ~kind:Method ~name:binder_name false (List.map (fun _ -> false) fields) sign
- in
- let coers = List.map2 (fun coe pri ->
- Option.map (fun b ->
- if b then Backward, pri else Forward, pri) coe)
- coers priorities
- in
- let l = List.map3 (fun decl b y -> get_name decl, b, y)
- (List.rev fields) coers (Recordops.lookup_projections ind)
- in IndRef ind, l
- in
- let ctx_context =
- List.map (fun decl ->
- match Typeclasses.class_of_constr (get_type decl) with
- | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true)
- | None -> None)
- params, params
- in
- let k =
- { cl_impl = impl;
- cl_strict = !typeclasses_strict;
- cl_unique = !typeclasses_unique;
- cl_context = ctx_context;
- cl_props = fields;
- cl_projs = projs }
- in
- add_class k; impl
-
-
-let add_constant_class cst =
- let ty = Universes.unsafe_type_of_global (ConstRef cst) in
- let ctx, arity = decompose_prod_assum ty in
- let tc =
- { cl_impl = ConstRef cst;
- cl_context = (List.map (const None) ctx, ctx);
- cl_props = [LocalAssum (Anonymous, arity)];
- cl_projs = [];
- cl_strict = !typeclasses_strict;
- cl_unique = !typeclasses_unique
- }
- in add_class tc;
- set_typeclass_transparency (EvalConstRef cst) false false
-
-let add_inductive_class ind =
- let mind, oneind = Global.lookup_inductive ind in
- let k =
- let ctx = oneind.mind_arity_ctxt in
- let inst = Univ.UContext.instance mind.mind_universes in
- let ty = Inductive.type_of_inductive
- (push_rel_context ctx (Global.env ()))
- ((mind,oneind),inst)
- in
- { cl_impl = IndRef ind;
- cl_context = List.map (const None) ctx, ctx;
- cl_props = [LocalAssum (Anonymous, ty)];
- cl_projs = [];
- cl_strict = !typeclasses_strict;
- cl_unique = !typeclasses_unique }
- in add_class k
-
-let declare_existing_class g =
- match g with
- | ConstRef x -> add_constant_class x
- | IndRef x -> add_inductive_class x
- | _ -> user_err_loc (Loc.dummy_loc, "declare_existing_class",
- Pp.str"Unsupported class type, only constants and inductives are allowed")
-
-open Vernacexpr
-
-(* [fs] corresponds to fields and [ps] to parameters; [coers] is a
- list telling if the corresponding fields must me declared as coercions
- or subinstances. *)
-let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,idbuild,s) =
- let cfs,notations = List.split cfs in
- let cfs,priorities = List.split cfs in
- let coers,fs = List.split cfs in
- let extract_name acc = function
- Vernacexpr.AssumExpr((_,Name id),_) -> id::acc
- | Vernacexpr.DefExpr ((_,Name id),_,_) -> id::acc
- | _ -> acc in
- let allnames = idstruc::(List.fold_left extract_name [] fs) in
- if not (List.distinct_f Id.compare allnames)
- then error "Two objects have the same name";
- let isnot_class = match kind with Class false -> false | _ -> true in
- if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then
- error "Priorities only allowed for type class substructures";
- (* Now, younger decl in params and fields is on top *)
- let (pl, ctx), arity, template, implpars, params, implfs, fields =
- States.with_state_protection (fun () ->
- typecheck_params_and_fields (kind = Class true) idstruc pl s ps notations fs) () in
- let sign = structure_signature (fields@params) in
- let gr = match kind with
- | Class def ->
- let priorities = List.map (fun id -> {hint_priority = id; hint_pattern = None}) priorities in
- let gr = declare_class finite def poly ctx (loc,idstruc) idbuild
- implpars params arity template implfs fields is_coe coers priorities sign in
- gr
- | _ ->
- let implfs = List.map
- (fun impls -> implpars @ Impargs.lift_implicits
- (succ (List.length params)) impls) implfs in
- let ind = declare_structure finite poly ctx idstruc
- idbuild implpars params arity template implfs
- fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) sign in
- IndRef ind
- in
- Universes.register_universe_binders gr pl;
- gr
diff --git a/toplevel/record.mli b/toplevel/record.mli
deleted file mode 100644
index c50e5778..00000000
--- a/toplevel/record.mli
+++ /dev/null
@@ -1,46 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Names
-open Term
-open Vernacexpr
-open Constrexpr
-open Impargs
-open Globnames
-
-val primitive_flag : bool ref
-
-(** [declare_projections ref name coers params fields] declare projections of
- record [ref] (if allowed) using the given [name] as argument, and put them
- as coercions accordingly to [coers]; it returns the absolute names of projections *)
-
-val declare_projections :
- inductive -> ?kind:Decl_kinds.definition_object_kind -> Id.t ->
- coercion_flag list -> manual_explicitation list list -> Context.Rel.t ->
- (Name.t * bool) list * constant option list
-
-val declare_structure :
- Decl_kinds.recursivity_kind ->
- bool (** polymorphic?*) -> Univ.universe_context ->
- Id.t -> Id.t ->
- manual_explicitation list -> Context.Rel.t -> (** params *) constr -> (** arity *)
- bool (** template arity ? *) ->
- Impargs.manual_explicitation list list -> Context.Rel.t -> (** fields *)
- ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t ->
- bool -> (** coercion? *)
- bool list -> (** field coercions *)
- Evd.evar_map ->
- inductive
-
-val definition_structure :
- inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind *
- plident with_coercion * local_binder list *
- (local_decl_expr with_instance with_priority with_notation) list *
- Id.t * constr_expr option -> global_reference
-
-val declare_existing_class : global_reference -> unit
diff --git a/toplevel/search.ml b/toplevel/search.ml
deleted file mode 100644
index ff3c7a4f..00000000
--- a/toplevel/search.ml
+++ /dev/null
@@ -1,315 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Util
-open Names
-open Term
-open Declarations
-open Libobject
-open Environ
-open Pattern
-open Printer
-open Libnames
-open Globnames
-open Nametab
-open Goptions
-
-type filter_function = global_reference -> env -> constr -> bool
-type display_function = global_reference -> env -> constr -> unit
-
-(* This option restricts the output of [SearchPattern ...],
-[SearchAbout ...], etc. to the names of the symbols matching the
-query, separated by a newline. This type of output is useful for
-editors (like emacs), to generate a list of completion candidates
-without having to parse thorugh the types of all symbols. *)
-
-type glob_search_about_item =
- | GlobSearchSubPattern of constr_pattern
- | GlobSearchString of string
-
-module SearchBlacklist =
- Goptions.MakeStringTable
- (struct
- let key = ["Search";"Blacklist"]
- let title = "Current search blacklist : "
- let member_message s b =
- str "Search blacklist does " ++ (if b then mt () else str "not ") ++ str "include " ++ str s
- let synchronous = true
- end)
-
-(* The functions iter_constructors and iter_declarations implement the behavior
- needed for the Coq searching commands.
- These functions take as first argument the procedure
- that will be called to treat each entry. This procedure receives the name
- of the object, the assumptions that will make it possible to print its type,
- and the constr term that represent its type. *)
-
-let iter_constructors indsp u fn env nconstr =
- for i = 1 to nconstr do
- let typ = Inductiveops.type_of_constructor env ((indsp, i), u) in
- fn (ConstructRef (indsp, i)) env typ
- done
-
-let iter_named_context_name_type f =
- let open Context.Named.Declaration in
- List.iter (fun decl -> f (get_id decl) (get_type decl))
-
-(* General search over hypothesis of a goal *)
-let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) =
- let env = Global.env () in
- let iter_hyp idh typ = fn (VarRef idh) env typ in
- let evmap,e = Pfedit.get_goal_context glnum in
- let pfctxt = named_context e in
- iter_named_context_name_type iter_hyp pfctxt
-
-(* General search over declarations *)
-let iter_declarations (fn : global_reference -> env -> constr -> unit) =
- let open Context.Named.Declaration in
- let env = Global.env () in
- let iter_obj (sp, kn) lobj = match object_tag lobj with
- | "VARIABLE" ->
- begin try
- let decl = Global.lookup_named (basename sp) in
- fn (VarRef (get_id decl)) env (get_type decl)
- with Not_found -> (* we are in a section *) () end
- | "CONSTANT" ->
- let cst = Global.constant_of_delta_kn kn in
- let gr = ConstRef cst in
- let typ = Global.type_of_global_unsafe gr in
- fn gr env typ
- | "INDUCTIVE" ->
- let mind = Global.mind_of_delta_kn kn in
- let mib = Global.lookup_mind mind in
- let iter_packet i mip =
- let ind = (mind, i) in
- let u = Declareops.inductive_instance mib in
- let i = (ind, u) in
- let typ = Inductiveops.type_of_inductive env i in
- let () = fn (IndRef ind) env typ in
- let len = Array.length mip.mind_user_lc in
- iter_constructors ind u fn env len
- in
- Array.iteri iter_packet mib.mind_packets
- | _ -> ()
- in
- try Declaremods.iter_all_segments iter_obj
- with Not_found -> ()
-
-let generic_search glnumopt fn =
- (match glnumopt with
- | None -> ()
- | Some glnum -> iter_hypothesis glnum fn);
- iter_declarations fn
-
-(** Filters *)
-
-(** This function tries to see whether the conclusion matches a pattern. *)
-(** FIXME: this is quite dummy, we may find a more efficient algorithm. *)
-let rec pattern_filter pat ref env typ =
- let typ = strip_outer_cast typ in
- if Constr_matching.is_matching env Evd.empty pat typ then true
- else match kind_of_term typ with
- | Prod (_, _, typ)
- | LetIn (_, _, _, typ) -> pattern_filter pat ref env typ
- | _ -> false
-
-let rec head_filter pat ref env typ =
- let typ = strip_outer_cast typ in
- if Constr_matching.is_matching_head env Evd.empty pat typ then true
- else match kind_of_term typ with
- | Prod (_, _, typ)
- | LetIn (_, _, _, typ) -> head_filter pat ref env typ
- | _ -> false
-
-let full_name_of_reference ref =
- let (dir,id) = repr_path (path_of_global ref) in
- DirPath.to_string dir ^ "." ^ Id.to_string id
-
-(** Whether a reference is blacklisted *)
-let blacklist_filter_aux () =
- let l = SearchBlacklist.elements () in
- fun ref env typ ->
- let name = full_name_of_reference ref in
- let is_not_bl str = not (String.string_contains ~where:name ~what:str) in
- List.for_all is_not_bl l
-
-let module_filter (mods, outside) ref env typ =
- let sp = path_of_global ref in
- let sl = dirpath sp in
- let is_outside md = not (is_dirpath_prefix_of md sl) in
- let is_inside md = is_dirpath_prefix_of md sl in
- if outside then List.for_all is_outside mods
- else List.is_empty mods || List.exists is_inside mods
-
-let name_of_reference ref = Id.to_string (basename_of_global ref)
-
-let search_about_filter query gr env typ = match query with
-| GlobSearchSubPattern pat ->
- Constr_matching.is_matching_appsubterm ~closed:false env Evd.empty pat typ
-| GlobSearchString s ->
- String.string_contains ~where:(name_of_reference gr) ~what:s
-
-
-(** SearchPattern *)
-
-let search_pattern gopt pat mods pr_search =
- let blacklist_filter = blacklist_filter_aux () in
- let filter ref env typ =
- module_filter mods ref env typ &&
- pattern_filter pat ref env typ &&
- blacklist_filter ref env typ
- in
- let iter ref env typ =
- if filter ref env typ then pr_search ref env typ
- in
- generic_search gopt iter
-
-(** SearchRewrite *)
-
-let eq = Coqlib.glob_eq
-
-let rewrite_pat1 pat =
- PApp (PRef eq, [| PMeta None; pat; PMeta None |])
-
-let rewrite_pat2 pat =
- PApp (PRef eq, [| PMeta None; PMeta None; pat |])
-
-let search_rewrite gopt pat mods pr_search =
- let pat1 = rewrite_pat1 pat in
- let pat2 = rewrite_pat2 pat in
- let blacklist_filter = blacklist_filter_aux () in
- let filter ref env typ =
- module_filter mods ref env typ &&
- (pattern_filter pat1 ref env typ ||
- pattern_filter pat2 ref env typ) &&
- blacklist_filter ref env typ
- in
- let iter ref env typ =
- if filter ref env typ then pr_search ref env typ
- in
- generic_search gopt iter
-
-(** Search *)
-
-let search_by_head gopt pat mods pr_search =
- let blacklist_filter = blacklist_filter_aux () in
- let filter ref env typ =
- module_filter mods ref env typ &&
- head_filter pat ref env typ &&
- blacklist_filter ref env typ
- in
- let iter ref env typ =
- if filter ref env typ then pr_search ref env typ
- in
- generic_search gopt iter
-
-(** SearchAbout *)
-
-let search_about gopt items mods pr_search =
- let blacklist_filter = blacklist_filter_aux () in
- let filter ref env typ =
- let eqb b1 b2 = if b1 then b2 else not b2 in
- module_filter mods ref env typ &&
- List.for_all
- (fun (b,i) -> eqb b (search_about_filter i ref env typ)) items &&
- blacklist_filter ref env typ
- in
- let iter ref env typ =
- if filter ref env typ then pr_search ref env typ
- in
- generic_search gopt iter
-
-type search_constraint =
- | Name_Pattern of Str.regexp
- | Type_Pattern of Pattern.constr_pattern
- | SubType_Pattern of Pattern.constr_pattern
- | In_Module of Names.DirPath.t
- | Include_Blacklist
-
-type 'a coq_object = {
- coq_object_prefix : string list;
- coq_object_qualid : string list;
- coq_object_object : 'a;
-}
-
-let interface_search =
- let rec extract_flags name tpe subtpe mods blacklist = function
- | [] -> (name, tpe, subtpe, mods, blacklist)
- | (Name_Pattern regexp, b) :: l ->
- extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l
- | (Type_Pattern pat, b) :: l ->
- extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l
- | (SubType_Pattern pat, b) :: l ->
- extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l
- | (In_Module id, b) :: l ->
- extract_flags name tpe subtpe ((id, b) :: mods) blacklist l
- | (Include_Blacklist, b) :: l ->
- extract_flags name tpe subtpe mods b l
- in
- fun ?glnum flags ->
- let (name, tpe, subtpe, mods, blacklist) =
- extract_flags [] [] [] [] false flags
- in
- let blacklist_filter = blacklist_filter_aux () in
- let filter_function ref env constr =
- let id = Names.Id.to_string (Nametab.basename_of_global ref) in
- let path = Libnames.dirpath (Nametab.path_of_global ref) in
- let toggle x b = if x then b else not b in
- let match_name (regexp, flag) =
- toggle (Str.string_match regexp id 0) flag
- in
- let match_type (pat, flag) =
- toggle (Constr_matching.is_matching env Evd.empty pat constr) flag
- in
- let match_subtype (pat, flag) =
- toggle
- (Constr_matching.is_matching_appsubterm ~closed:false
- env Evd.empty pat constr) flag
- in
- let match_module (mdl, flag) =
- toggle (Libnames.is_dirpath_prefix_of mdl path) flag
- in
- List.for_all match_name name &&
- List.for_all match_type tpe &&
- List.for_all match_subtype subtpe &&
- List.for_all match_module mods &&
- (blacklist || blacklist_filter ref env constr)
- in
- let ans = ref [] in
- let print_function ref env constr =
- let fullpath = DirPath.repr (Nametab.dirpath_of_global ref) in
- let qualid = Nametab.shortest_qualid_of_global Id.Set.empty ref in
- let (shortpath, basename) = Libnames.repr_qualid qualid in
- let shortpath = DirPath.repr shortpath in
- (* [shortpath] is a suffix of [fullpath] and we're looking for the missing
- prefix *)
- let rec prefix full short accu = match full, short with
- | _, [] ->
- let full = List.rev_map Id.to_string full in
- (full, accu)
- | _ :: full, m :: short ->
- prefix full short (Id.to_string m :: accu)
- | _ -> assert false
- in
- let (prefix, qualid) = prefix fullpath shortpath [Id.to_string basename] in
- let answer = {
- coq_object_prefix = prefix;
- coq_object_qualid = qualid;
- coq_object_object = string_of_ppcmds (pr_lconstr_env env Evd.empty constr);
- } in
- ans := answer :: !ans;
- in
- let iter ref env typ =
- if filter_function ref env typ then print_function ref env typ
- in
- let () = generic_search glnum iter in
- !ans
-
-let blacklist_filter ref env typ =
- blacklist_filter_aux () ref env typ
diff --git a/toplevel/search.mli b/toplevel/search.mli
deleted file mode 100644
index ba3d48ef..00000000
--- a/toplevel/search.mli
+++ /dev/null
@@ -1,76 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp
-open Names
-open Term
-open Environ
-open Pattern
-open Globnames
-
-(** {6 Search facilities. } *)
-
-type glob_search_about_item =
- | GlobSearchSubPattern of constr_pattern
- | GlobSearchString of string
-
-type filter_function = global_reference -> env -> constr -> bool
-type display_function = global_reference -> env -> constr -> unit
-
-(** {6 Generic filter functions} *)
-
-val blacklist_filter : filter_function
-(** Check whether a reference is blacklisted. *)
-
-val module_filter : DirPath.t list * bool -> filter_function
-(** Check whether a reference pertains or not to a set of modules *)
-
-val search_about_filter : glob_search_about_item -> filter_function
-(** Check whether a reference matches a SearchAbout query. *)
-
-(** {6 Specialized search functions}
-
-[search_xxx gl pattern modinout] searches the hypothesis of the [gl]th
-goal and the global environment for things matching [pattern] and
-satisfying module exclude/include clauses of [modinout]. *)
-
-val search_by_head : int option -> constr_pattern -> DirPath.t list * bool
- -> display_function -> unit
-val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool
- -> display_function -> unit
-val search_pattern : int option -> constr_pattern -> DirPath.t list * bool
- -> display_function -> unit
-val search_about : int option -> (bool * glob_search_about_item) list
- -> DirPath.t list * bool -> display_function -> unit
-
-type search_constraint =
- (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *)
- | Name_Pattern of Str.regexp
- (** Whether the object type satisfies a pattern *)
- | Type_Pattern of Pattern.constr_pattern
- (** Whether some subtype of object type satisfies a pattern *)
- | SubType_Pattern of Pattern.constr_pattern
- (** Whether the object pertains to a module *)
- | In_Module of Names.DirPath.t
- (** Bypass the Search blacklist *)
- | Include_Blacklist
-
-type 'a coq_object = {
- coq_object_prefix : string list;
- coq_object_qualid : string list;
- coq_object_object : 'a;
-}
-
-val interface_search : ?glnum:int -> (search_constraint * bool) list ->
- string coq_object list
-
-(** {6 Generic search function} *)
-
-val generic_search : int option -> display_function -> unit
-(** This function iterates over all hypothesis of the goal numbered
- [glnum] (if present) and all known declarations. *)
diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib
index d6892236..9fb2e33d 100644
--- a/toplevel/toplevel.mllib
+++ b/toplevel/toplevel.mllib
@@ -1,21 +1,6 @@
-Himsg
-ExplainErr
-Class
-Locality
-Metasyntax
-Auto_ind_decl
-Search
-Indschemes
-Obligations
-Command
-Classes
-Record
-Assumptions
-Vernacinterp
-Mltop
-Vernacentries
Vernac
Usage
Coqloop
Coqinit
+Coqargs
Coqtop
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 38ceacf5..504ffa52 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -1,9 +1,11 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
let version ret =
@@ -30,7 +32,7 @@ let print_usage_channel co command =
\n -R dir coqdir recursively map physical dir to logical coqdir\
\n -Q dir coqdir map physical dir to logical coqdir\
\n -top coqdir set the toplevel name to be coqdir instead of Top\
-\n -notop set the toplevel name to be the empty logical path\
+\n -coqlib dir set the coq standard library directory\
\n -exclude-dir f exclude subdirectories named f for option -R\
\n\
\n -noinit start without loading the Init library\
@@ -56,7 +58,8 @@ let print_usage_channel co command =
\n\
\n -where print Coq's standard library location and exit\
\n -config, --config print Coq's configuration information and exit\
-\n -v print Coq version and exit\
+\n -v, --version print Coq version and exit\
+\n -print-version print Coq version in easy to parse format and exit\
\n -list-tags print highlight color tags known by Coq and exit\
\n\
\n -quiet unset display of extra information (implies -w \"-all\")\
@@ -69,22 +72,20 @@ let print_usage_channel co command =
\n -boot boot mode (implies -q and -batch)\
\n -bt print backtraces (requires configure debug flag)\
\n -debug debug mode (implies -bt)\
+\n -stm-debug STM debug mode (will trace every transaction) \
\n -emacs tells Coq it is executed under Emacs\
\n -noglob do not dump globalizations\
\n -dump-glob f dump globalizations in file f (to be used by coqdoc)\
-\n -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)\
\n -impredicative-set set sort Set impredicative\
\n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\
\n -type-in-type disable universe consistency checking\
-\n -xml export XML files either to the hierarchy rooted in\
-\n the directory $COQ_XML_LIBRARY_ROOT (if set) or to\
-\n stdout (if unset)\
+\n -mangle-names x mangle auto-generated names using prefix x\
\n -time display the time taken by each command\
\n -profile-ltac display the time taken by each (sub)tactic\
\n -m, --memory display total heap size at program exit\
\n (use environment variable\
\n OCAML_GC_STATS=\"/tmp/gclog.txt\"\
-\n for full Gc stats dump)
+\n for full Gc stats dump)\
\n -native-compiler precompile files for the native_compute machinery\
\n -h, -help, --help print this list of options\
\n";
@@ -115,16 +116,3 @@ let print_usage_coqc () =
flush stderr ;
exit 1
-(* Print the configuration information *)
-
-let print_config () =
- if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n";
- Printf.printf "COQLIB=%s/\n" (Envars.coqlib ());
- Printf.printf "DOCDIR=%s/\n" (Envars.docdir ());
- Printf.printf "OCAMLFIND=%s\n" (Envars.ocamlfind ());
- Printf.printf "CAMLP4=%s\n" Coq_config.camlp4;
- Printf.printf "CAMLP4O=%s\n" Coq_config.camlp4o;
- Printf.printf "CAMLP4BIN=%s/\n" (Envars.camlp4bin ());
- Printf.printf "CAMLP4LIB=%s\n" (Envars.camlp4lib ());
- Printf.printf "CAMLP4OPTIONS=%s\n" Coq_config.camlp4compat;
- Printf.printf "HASNATDYNLINK=%s\n" (if Coq_config.has_natdynlink then "true" else "false")
diff --git a/toplevel/usage.mli b/toplevel/usage.mli
index dccb40e7..fbb0117d 100644
--- a/toplevel/usage.mli
+++ b/toplevel/usage.mli
@@ -1,9 +1,11 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
(** {6 Prints the version number on the standard output and exits (with 0). } *)
@@ -21,5 +23,3 @@ val add_to_usage : string -> string -> unit
val print_usage_coqtop : unit -> unit
val print_usage_coqc : unit -> unit
-(** {6 Prints the configuration information } *)
-val print_config : unit -> unit
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index bfdae85d..fdd0d4ed 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.ml
@@ -1,9 +1,11 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
(* Parsing of vernacular. *)
@@ -11,165 +13,48 @@
open Pp
open CErrors
open Util
-open Flags
open Vernacexpr
+open Vernacprop
(* The functions in this module may raise (unexplainable!) exceptions.
Use the module Coqtoplevel, which catches these exceptions
(the exceptions are explained only at the toplevel). *)
-let user_error loc s = CErrors.user_err_loc (loc,"_",str s)
-
-(* Navigation commands are allowed in a coqtop session but not in a .v file *)
-
-let rec is_navigation_vernac = function
- | VernacResetInitial
- | VernacResetName _
- | VernacBacktrack _
- | VernacBackTo _
- | VernacBack _
- | VernacStm _ -> true
- | VernacRedirect (_, (_,c))
- | VernacTime (_,c) ->
- is_navigation_vernac c (* Time Back* is harmless *)
- | c -> is_deep_navigation_vernac c
-
-and is_deep_navigation_vernac = function
- | VernacTimeout (_,c) | VernacFail c -> is_navigation_vernac c
- | _ -> false
-
-(* NB: Reset is now allowed again as asked by A. Chlipala *)
-
-let is_reset = function
- | VernacResetInitial | VernacResetName _ -> true
- | _ -> false
-
-let checknav_simple loc cmd =
+let checknav_simple {CAst.loc;v=cmd} =
if is_navigation_vernac cmd && not (is_reset cmd) then
- user_error loc "Navigation commands forbidden in files."
+ CErrors.user_err ?loc (str "Navigation commands forbidden in files.")
-let checknav_deep loc ast =
+let checknav_deep {CAst.loc;v=ast} =
if is_deep_navigation_vernac ast then
- user_error loc "Navigation commands forbidden in nested commands."
-
-(* When doing Load on a file, two behaviors are possible:
-
- - either the history stack is grown by only one command,
- the "Load" itself. This is mandatory for command-counting
- interfaces (CoqIDE).
-
- - either each individual sub-commands in the file is added
- to the history stack. This allows commands like Show Script
- to work across the loaded file boundary (cf. bug #2820).
-
- The best of the two could probably be combined someday,
- in the meanwhile we use a flag. *)
-
-let atomic_load = ref true
-
-let _ =
- Goptions.declare_bool_option
- { Goptions.optsync = true;
- Goptions.optdepr = false;
- Goptions.optname = "atomic registration of commands in a Load";
- Goptions.optkey = ["Atomic";"Load"];
- Goptions.optread = (fun () -> !atomic_load);
- Goptions.optwrite = ((:=) atomic_load) }
+ CErrors.user_err ?loc (str "Navigation commands forbidden in nested commands.")
let disable_drop = function
- | Drop -> CErrors.error "Drop is forbidden."
+ | Drop -> CErrors.user_err Pp.(str "Drop is forbidden.")
| e -> e
-(* Opening and closing a channel. Open it twice when verbose: the first
- channel is used to read the commands, and the second one to print them.
- Note: we could use only one thanks to seek_in, but seeking on and on in
- the file we parse seems a bit risky to me. B.B. *)
-
-let open_file_twice_if verbosely longfname =
- let in_chan = open_utf8_file_in longfname in
- let verb_ch =
- if verbosely then Some (open_utf8_file_in longfname) else None in
- let po = Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in
- (in_chan, longfname, (po, verb_ch))
-
-let close_input in_chan (_,verb) =
- try
- close_in in_chan;
- match verb with
- | Some verb_ch -> close_in verb_ch
- | _ -> ()
- with e when CErrors.noncritical e -> ()
-
-let verbose_phrase verbch loc =
- let loc = Loc.unloc loc in
- match verbch with
- | Some ch ->
- let len = snd loc - fst loc in
- let s = String.create len in
- seek_in ch (fst loc);
- really_input ch s 0 len;
- Feedback.msg_notice (str s)
- | None -> ()
-
-exception End_of_input
-
-let parse_sentence = Flags.with_option Flags.we_are_parsing
- (fun (po, verbch) ->
- match Pcoq.Gram.entry_parse Pcoq.main_entry po with
- | Some (loc,_ as com) -> verbose_phrase verbch loc; com
- | None -> raise End_of_input)
-
-(* vernac parses the given stream, executes interpfun on the syntax tree it
- * parses, and is verbose on "primitives" commands if verbosely is true *)
-
-let chan_beautify = ref stdout
-let beautify_suffix = ".beautified"
-
-let set_formatter_translator ch =
- let out s b e = output ch s b e in
- Format.set_formatter_output_functions out (fun () -> flush ch);
- Format.set_max_boxes max_int
-
-let pr_new_syntax_in_context loc chan_beautify ocom =
- let loc = Loc.unloc loc in
- if !beautify_file then set_formatter_translator chan_beautify;
- let fs = States.freeze ~marshallable:`No in
- (* The content of this is not supposed to fail, but if ever *)
- try
- (* Side-effect: order matters *)
- let before = comment (CLexer.extract_comments (fst loc)) in
- let com = match ocom with
- | Some com -> Ppvernac.pr_vernac com
- | None -> mt() in
- let after = comment (CLexer.extract_comments (snd loc)) in
- if !beautify_file then
- Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after))
- else
- Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)));
- States.unfreeze fs;
- Format.set_formatter_out_channel stdout
- with any ->
- States.unfreeze fs;
- Format.set_formatter_out_channel stdout
-
-let pr_new_syntax po loc chan_beautify ocom =
- (* Reinstall the context of parsing which includes the bindings of comments to locations *)
- Pcoq.Gram.with_parsable po (pr_new_syntax_in_context chan_beautify loc) ocom
+(* Echo from a buffer based on position.
+ XXX: Should move to utility file. *)
+let vernac_echo ?loc in_chan = let open Loc in
+ Option.iter (fun loc ->
+ let len = loc.ep - loc.bp in
+ seek_in in_chan loc.bp;
+ Feedback.msg_notice @@ str @@ really_input_string in_chan len
+ ) loc
(* For coqtop -time, we display the position in the file,
and a glimpse of the executed command *)
-let pp_cmd_header loc com =
- let shorten s = try (String.sub s 0 30)^"..." with _ -> s in
- let noblank s =
- for i = 0 to String.length s - 1 do
- match s.[i] with
- | ' ' | '\n' | '\t' | '\r' -> s.[i] <- '~'
- | _ -> ()
- done;
- s
+let pp_cmd_header {CAst.loc;v=com} =
+ let shorten s =
+ if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s
in
- let (start,stop) = Loc.unloc loc in
+ let noblank s = String.map (fun c ->
+ match c with
+ | ' ' | '\n' | '\t' | '\r' -> '~'
+ | x -> x
+ ) s
+ in
+ let (start,stop) = Option.cata Loc.unloc (0,0) loc in
let safe_pr_vernac x =
try Ppvernac.pr_vernac x
with e -> str (Printexc.to_string e) in
@@ -180,173 +65,164 @@ let pp_cmd_header loc com =
(* This is a special case where we assume we are in console batch mode
and take control of the console.
*)
-let print_cmd_header loc com =
- Pp.pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (pp_cmd_header loc com);
- Format.pp_print_flush !Pp_control.std_ft ()
+let print_cmd_header com =
+ Pp.pp_with !Topfmt.std_ft (pp_cmd_header com);
+ Format.pp_print_flush !Topfmt.std_ft ()
-let rec interp_vernac po chan_beautify checknav (loc,com) =
- let interp = function
- | VernacLoad (verbosely, fname) ->
- let fname = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in
- let fname = CUnix.make_suffix fname ".v" in
- let f = Loadpath.locate_file fname in
- load_vernac verbosely f
+(* Reenable when we get back to feedback printing *)
+(* let is_end_of_input any = match any with *)
+(* Stm.End_of_input -> true *)
+(* | _ -> false *)
- | v -> Stm.interp (Flags.is_verbose()) (loc,v)
- in
+module State = struct
+
+ type t = {
+ doc : Stm.doc;
+ sid : Stateid.t;
+ proof : Proof.t option;
+ }
+
+end
+
+let interp_vernac ~time ~check ~interactive ~state ({CAst.loc;_} as com) =
+ let open State in
try
- checknav loc com;
- if !beautify then pr_new_syntax po chan_beautify loc (Some com);
- (* XXX: This is not 100% correct if called from an IDE context *)
- if !Flags.time then print_cmd_header loc com;
- let com = if !Flags.time then VernacTime (loc,com) else com in
- interp com
+ (* The -time option is only supported from console-based clients
+ due to the way it prints. *)
+ if time then print_cmd_header com;
+ let com = if time then CAst.make ?loc @@ VernacTime(time,com) else com in
+ let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) com in
+
+ (* Main STM interaction *)
+ if ntip <> `NewTip then
+ anomaly (str "vernac.ml: We got an unfocus operation on the toplevel!");
+
+ (* Due to bug #5363 we cannot use observe here as we should,
+ it otherwise reveals bugs *)
+ (* Stm.observe nsid; *)
+ let ndoc = if check then Stm.finish ~doc else doc in
+ let new_proof = Proof_global.give_me_the_proof_opt () in
+ { doc = ndoc; sid = nsid; proof = new_proof }
with reraise ->
+ (* XXX: In non-interactive mode edit_at seems to do very weird
+ things, so we better avoid it while we investigate *)
+ if interactive then ignore(Stm.edit_at ~doc:state.doc state.sid);
let (reraise, info) = CErrors.push reraise in
- let loc' = Option.default Loc.ghost (Loc.get_loc info) in
- if Loc.is_ghost loc' then iraise (reraise, Loc.add_loc info loc)
- else iraise (reraise, info)
+ let info = begin
+ match Loc.get_loc info with
+ | None -> Option.cata (Loc.add_loc info) info loc
+ | Some _ -> info
+ end in iraise (reraise, info)
(* Load a vernac file. CErrors are annotated with file and location *)
-and load_vernac verbosely file =
- let chan_beautify =
- if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout in
- let (in_chan, fname, input) = open_file_twice_if verbosely file in
+let load_vernac_core ~time ~echo ~check ~interactive ~state file =
+ (* Keep in sync *)
+ let in_chan = open_utf8_file_in file in
+ let in_echo = if echo then Some (open_utf8_file_in file) else None in
+ let input_cleanup () = close_in in_chan; Option.iter close_in in_echo in
+
+ let in_pa = Pcoq.Gram.parsable ~file:(Loc.InFile file) (Stream.of_channel in_chan) in
+ let rstate = ref state in
+ (* For beautify, list of parsed sids *)
+ let rids = ref [] in
+ let open State in
try
(* we go out of the following infinite loop when a End_of_input is
* raised, which means that we raised the end of the file being loaded *)
while true do
- let loc_ast = Flags.silently parse_sentence input in
- CWarnings.set_current_loc (fst loc_ast);
- Flags.silently (interp_vernac (fst input) chan_beautify checknav_simple) loc_ast;
- done
+ let { CAst.loc; _ } as ast =
+ Stm.parse_sentence ~doc:!rstate.doc !rstate.sid in_pa
+ (* If an error in parsing occurs, we propagate the exception
+ so the caller of load_vernac will take care of it. However,
+ in the future it could be possible that we want to handle
+ all the errors as feedback events, thus in this case we
+ should relay the exception here for convenience. A
+ possibility is shown below, however we may want to refactor
+ this code:
+
+ try Stm.parse_sentence !rsid in_pa
+ with
+ | any when not is_end_of_input any ->
+ let (e, info) = CErrors.push any in
+ let loc = Loc.get_loc info in
+ let msg = CErrors.iprint (e, info) in
+ Feedback.msg_error ?loc msg;
+ iraise (e, info)
+ *)
+ in
+ (* Printing of vernacs *)
+ Option.iter (vernac_echo ?loc) in_echo;
+
+ checknav_simple ast;
+ let state = Flags.silently (interp_vernac ~time ~check ~interactive ~state:!rstate) ast in
+ rids := state.sid :: !rids;
+ rstate := state;
+ done;
+ input_cleanup ();
+ !rstate, !rids, Pcoq.Gram.comment_state in_pa
with any -> (* whatever the exception *)
let (e, info) = CErrors.push any in
- close_input in_chan input; (* we must close the file first *)
+ input_cleanup ();
match e with
- | End_of_input ->
- if !beautify then
- pr_new_syntax (fst input) chan_beautify (Loc.make_loc (max_int,max_int)) None;
- if !Flags.beautify_file then close_out chan_beautify;
- | reraise ->
- if !Flags.beautify_file then close_out chan_beautify;
- iraise (disable_drop e, info)
-
-(** [eval_expr : ?preserving:bool -> Loc.t * Vernacexpr.vernac_expr -> unit]
- It executes one vernacular command. By default the command is
- considered as non-state-preserving, in which case we add it to the
- Backtrack stack (triggering a save of a frozen state and the generation
- of a new state label). An example of state-preserving command is one coming
- from the query panel of Coqide. *)
-
-let process_expr po loc_ast = interp_vernac po stdout checknav_deep loc_ast
-
-(* XML output hooks *)
-let (f_xml_start_library, xml_start_library) = Hook.make ~default:ignore ()
-let (f_xml_end_library, xml_end_library) = Hook.make ~default:ignore ()
+ | Stm.End_of_input -> !rstate, !rids, Pcoq.Gram.comment_state in_pa
+ | reraise -> iraise (disable_drop e, info)
-let warn_file_no_extension =
- CWarnings.create ~name:"file-no-extension" ~category:"filesystem"
- (fun (f,ext) ->
- str "File \"" ++ str f ++
- strbrk "\" has been implicitly expanded to \"" ++
- str f ++ str ext ++ str "\"")
+let process_expr ~time ~state loc_ast =
+ checknav_deep loc_ast;
+ interp_vernac ~time ~interactive:true ~check:true ~state loc_ast
-let ensure_ext ext f =
- if Filename.check_suffix f ext then f
- else begin
- warn_file_no_extension (f,ext);
- f ^ ext
- end
+(******************************************************************************)
+(* Beautify-specific code *)
+(******************************************************************************)
-let chop_extension f =
- try Filename.chop_extension f with _ -> f
-
-let ensure_bname src tgt =
- let src, tgt = Filename.basename src, Filename.basename tgt in
- let src, tgt = chop_extension src, chop_extension tgt in
- if src <> tgt then begin
- Feedback.msg_error (str "Source and target file names must coincide, directories can differ");
- Feedback.msg_error (str "Source: " ++ str src);
- Feedback.msg_error (str "Target: " ++ str tgt);
- flush_all ();
- exit 1
- end
-
-let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt
-
-let ensure_v v = ensure ".v" v v
-let ensure_vo v vo = ensure ".vo" v vo
-let ensure_vio v vio = ensure ".vio" v vio
-
-let ensure_exists f =
- if not (Sys.file_exists f) then begin
- Feedback.msg_error (hov 0 (str "Can't find file" ++ spc () ++ str f));
- exit 1
- end
-
-(* Compile a vernac file *)
-let compile verbosely f =
- let check_pending_proofs () =
- let pfs = Pfedit.get_all_proof_names () in
- if not (List.is_empty pfs) then
- (Feedback.msg_error (str "There are pending proofs"); flush_all (); exit 1) in
- match !Flags.compilation_mode with
- | BuildVo ->
- let long_f_dot_v = ensure_v f in
- ensure_exists long_f_dot_v;
- let long_f_dot_vo =
- match !Flags.compilation_output_name with
- | None -> long_f_dot_v ^ "o"
- | Some f -> ensure_vo long_f_dot_v f in
- let ldir = Flags.verbosely Library.start_library long_f_dot_vo in
- Stm.set_compilation_hints long_f_dot_vo;
- Aux_file.(start_aux_file
- ~aux_file:(aux_file_name_for long_f_dot_vo)
- ~v_file:long_f_dot_v);
- Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo;
- Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n");
- if !Flags.xml_export then Hook.get f_xml_start_library ();
- let wall_clock1 = Unix.gettimeofday () in
- let _ = load_vernac verbosely long_f_dot_v in
- Stm.join ();
- let wall_clock2 = Unix.gettimeofday () in
- check_pending_proofs ();
- Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ());
- Aux_file.record_in_aux_at Loc.ghost "vo_compile_time"
- (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1));
- Aux_file.stop_aux_file ();
- if !Flags.xml_export then Hook.get f_xml_end_library ();
- Dumpglob.end_dump_glob ()
- | BuildVio ->
- let long_f_dot_v = ensure_v f in
- ensure_exists long_f_dot_v;
- let long_f_dot_vio =
- match !Flags.compilation_output_name with
- | None -> long_f_dot_v ^ "io"
- | Some f -> ensure_vio long_f_dot_v f in
- let ldir = Flags.verbosely Library.start_library long_f_dot_vio in
- Dumpglob.noglob ();
- Stm.set_compilation_hints long_f_dot_vio;
- let _ = load_vernac verbosely long_f_dot_v in
- Stm.finish ();
- check_pending_proofs ();
- Stm.snapshot_vio ldir long_f_dot_vio;
- Stm.reset_task_queue ()
- | Vio2Vo ->
- let open Filename in
- let open Library in
- Dumpglob.noglob ();
- let f = if check_suffix f ".vio" then chop_extension f else f in
- let lfdv, sum, lib, univs, disch, tasks, proofs = load_library_todo f in
- Stm.set_compilation_hints lfdv;
- let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in
- Library.save_library_raw lfdv sum lib univs proofs
-
-let compile v f =
- ignore(CoqworkmgrApi.get 1);
- compile v f;
- CoqworkmgrApi.giveback 1
+(* vernac parses the given stream, executes interpfun on the syntax tree it
+ * parses, and is verbose on "primitives" commands if verbosely is true *)
+let beautify_suffix = ".beautified"
-let () = Hook.set Stm.process_error_hook
- ExplainErr.process_vernac_interp_error
+let set_formatter_translator ch =
+ let out s b e = output_substring ch s b e in
+ let ft = Format.make_formatter out (fun () -> flush ch) in
+ Format.pp_set_max_boxes ft max_int;
+ ft
+
+let pr_new_syntax ?loc ft_beautify ocom =
+ let loc = Option.cata Loc.unloc (0,0) loc in
+ let before = comment (Pputils.extract_comments (fst loc)) in
+ let com = Option.cata Ppvernac.pr_vernac (mt ()) ocom in
+ let after = comment (Pputils.extract_comments (snd loc)) in
+ if !Flags.beautify_file then
+ (Pp.pp_with ft_beautify (hov 0 (before ++ com ++ after));
+ Format.pp_print_flush ft_beautify ())
+ else
+ Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)))
+
+(* load_vernac with beautify *)
+let beautify_pass ~doc ~comments ~ids ~filename =
+ let ft_beautify, close_beautify =
+ if !Flags.beautify_file then
+ let chan_beautify = open_out (filename^beautify_suffix) in
+ set_formatter_translator chan_beautify, fun () -> close_out chan_beautify;
+ else
+ !Topfmt.std_ft, fun () -> ()
+ in
+ (* The interface to the comment printer is imperative, so we first
+ set the comments, then we call print. This has to be done for
+ each file. *)
+ Pputils.beautify_comments := comments;
+ List.iter (fun id ->
+ Option.iter (fun (loc,ast) ->
+ pr_new_syntax ?loc ft_beautify (Some ast))
+ (Stm.get_ast ~doc id)) ids;
+
+ (* Is this called so comments at EOF are printed? *)
+ pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) ft_beautify None;
+ close_beautify ()
+
+(* Main driver for file loading. For now, we only do one beautify
+ pass. *)
+let load_vernac ~time ~echo ~check ~interactive ~state filename =
+ let ostate, ids, comments = load_vernac_core ~time ~echo ~check ~interactive ~state filename in
+ (* Pass for beautify *)
+ if !Flags.beautify then beautify_pass ~doc:ostate.State.doc ~comments ~ids:List.(rev ids) ~filename;
+ (* End pass *)
+ ostate
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
index 0d9f5871..51758642 100644
--- a/toplevel/vernac.mli
+++ b/toplevel/vernac.mli
@@ -1,37 +1,32 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
(** Parsing of vernacular. *)
-
-(** Read a vernac command on the specified input (parse only).
- Raises [End_of_file] if EOF (or Ctrl-D) is reached. *)
-
-val parse_sentence : Pcoq.Gram.coq_parsable * in_channel option ->
- Loc.t * Vernacexpr.vernac_expr
-
-(** Reads and executes vernac commands from a stream. *)
-
-exception End_of_input
-
-val process_expr : Pcoq.Gram.coq_parsable -> Loc.t * Vernacexpr.vernac_expr -> unit
-
-(** Set XML hooks *)
-val xml_start_library : (unit -> unit) Hook.t
-val xml_end_library : (unit -> unit) Hook.t
-
-(** Load a vernac file, verbosely or not. Errors are annotated with file
- and location *)
-
-val load_vernac : bool -> string -> unit
-
-
-(** Compile a vernac file, verbosely or not (f is assumed without .v suffix) *)
-
-val compile : bool -> string -> unit
-
-val is_navigation_vernac : Vernacexpr.vernac_expr -> bool
+module State : sig
+
+ type t = {
+ doc : Stm.doc;
+ sid : Stateid.t;
+ proof : Proof.t option;
+ }
+
+end
+
+(** [process_expr sid cmd] Executes vernac command [cmd]. Callers are
+ expected to handle and print errors in form of exceptions, however
+ care is taken so the state machine is left in a consistent
+ state. *)
+val process_expr : time:bool -> state:State.t -> Vernacexpr.vernac_control CAst.t -> State.t
+
+(** [load_vernac echo sid file] Loads [file] on top of [sid], will
+ echo the commands if [echo] is set. Callers are expected to handle
+ and print errors in form of exceptions. *)
+val load_vernac : time:bool -> echo:bool -> check:bool -> interactive:bool ->
+ state:State.t -> string -> State.t
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
deleted file mode 100644
index 41ee165f..00000000
--- a/toplevel/vernacentries.ml
+++ /dev/null
@@ -1,2257 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* Concrete syntax of the mathematical vernacular MV V2.6 *)
-
-open Pp
-open CErrors
-open Util
-open Flags
-open Names
-open Nameops
-open Term
-open Pfedit
-open Tacmach
-open Constrintern
-open Prettyp
-open Printer
-open Command
-open Goptions
-open Libnames
-open Globnames
-open Vernacexpr
-open Decl_kinds
-open Constrexpr
-open Redexpr
-open Lemmas
-open Misctypes
-open Locality
-open Sigma.Notations
-
-(** TODO: make this function independent of Ltac *)
-let (f_interp_redexp, interp_redexp_hook) = Hook.make ()
-
-let debug = false
-let prerr_endline x =
- if debug then prerr_endline (x ()) else ()
-
-(* Misc *)
-
-let cl_of_qualid = function
- | FunClass -> Classops.CL_FUN
- | SortClass -> Classops.CL_SORT
- | RefClass r -> Class.class_of_global (Smartlocate.smart_global ~head:true r)
-
-let scope_class_of_qualid qid =
- Notation.scope_class_of_class (cl_of_qualid qid)
-
-(*******************)
-(* "Show" commands *)
-
-let show_proof () =
- (* spiwack: this would probably be cooler with a bit of polishing. *)
- let p = Proof_global.give_me_the_proof () in
- let pprf = Proof.partial_proof p in
- Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_constr pprf)
-
-let show_node () =
- (* spiwack: I'm have little clue what this function used to do. I deactivated it,
- could, possibly, be cleaned away. (Feb. 2010) *)
- ()
-
-let show_thesis () =
- Feedback.msg_error (anomaly (Pp.str "TODO") )
-
-let show_top_evars () =
- (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *)
- let pfts = get_pftreestate () in
- let gls = Proof.V82.subgoals pfts in
- let sigma = gls.Evd.sigma in
- Feedback.msg_notice (pr_evars_int sigma 1 (Evarutil.non_instantiated sigma))
-
-let show_universes () =
- let pfts = get_pftreestate () in
- let gls = Proof.V82.subgoals pfts in
- let sigma = gls.Evd.sigma in
- let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in
- Feedback.msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma));
- Feedback.msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Evd.pr_evd_level sigma) ctx)
-
-let show_prooftree () =
- (* Spiwack: proof tree is currently not working *)
- ()
-
-let enable_goal_printing = ref true
-
-let print_subgoals () =
- if !enable_goal_printing && is_verbose ()
- then begin
- Feedback.msg_notice (pr_open_subgoals ())
- end
-
-let try_print_subgoals () =
- try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> ()
-
-
- (* Simulate the Intro(s) tactic *)
-
-let show_intro all =
- let pf = get_pftreestate() in
- let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in
- if not (List.is_empty gls) then begin
- let gl = {Evd.it=List.hd gls ; sigma = sigma; } in
- let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in
- if all then
- let lid = Tactics.find_intro_names l gl in
- Feedback.msg_notice (hov 0 (prlist_with_sep spc pr_id lid))
- else if not (List.is_empty l) then
- let n = List.last l in
- Feedback.msg_notice (pr_id (List.hd (Tactics.find_intro_names [n] gl)))
- end
-
-(** Prepare a "match" template for a given inductive type.
- For each branch of the match, we list the constructor name
- followed by enough pattern variables.
- [Not_found] is raised if the given string isn't the qualid of
- a known inductive type. *)
-
-let make_cases_aux glob_ref =
- match glob_ref with
- | Globnames.IndRef i ->
- let {Declarations.mind_nparams = np}
- , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr }
- = Global.lookup_inductive i in
- Util.Array.fold_right2
- (fun consname typ l ->
- let al = List.rev (fst (decompose_prod typ)) in
- let al = Util.List.skipn np al in
- let rec rename avoid = function
- | [] -> []
- | (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 consname :: al') :: l)
- carr tarr []
- | _ -> raise Not_found
-
-let make_cases s =
- let qualified_name = Libnames.qualid_of_string s in
- let glob_ref = Nametab.locate qualified_name in
- make_cases_aux glob_ref
-
-(** Textual display of a generic "match" template *)
-
-let show_match id =
- let patterns =
- try make_cases_aux (Nametab.global id)
- with Not_found -> error "Unknown inductive type."
- in
- let pr_branch l =
- str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>"
- in
- Feedback.msg_notice (v 1 (str "match # with" ++ fnl () ++
- prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ()))
-
-(* "Print" commands *)
-
-let print_path_entry p =
- let dir = pr_dirpath (Loadpath.logical p) in
- let path = str (Loadpath.physical p) in
- (dir ++ str " " ++ tbrk (0, 0) ++ path)
-
-let print_loadpath dir =
- let l = Loadpath.get_load_paths () in
- let l = match dir with
- | None -> l
- | Some dir ->
- let filter p = is_dirpath_prefix_of dir (Loadpath.logical p) in
- List.filter filter l
- in
- Pp.t (str "Logical Path: " ++
- tab () ++ str "Physical path:" ++ fnl () ++
- prlist_with_sep fnl print_path_entry l)
-
-let print_modules () =
- let opened = Library.opened_libraries ()
- and loaded = Library.loaded_libraries () in
- (* we intersect over opened to preserve the order of opened since *)
- (* non-commutative operations (e.g. visibility) are done at import time *)
- let loaded_opened = List.intersect DirPath.equal opened loaded
- and only_loaded = List.subtract DirPath.equal loaded opened in
- str"Loaded and imported library files: " ++
- pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++
- str"Loaded and not imported library files: " ++
- pr_vertical_list pr_dirpath only_loaded
-
-
-let print_module r =
- let (loc,qid) = qualid_of_reference r in
- try
- let globdir = Nametab.locate_dir qid in
- match globdir with
- DirModule (dirpath,(mp,_)) ->
- Feedback.msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp)
- | _ -> raise Not_found
- with
- Not_found -> Feedback.msg_error (str"Unknown Module " ++ pr_qualid qid)
-
-let print_modtype r =
- let (loc,qid) = qualid_of_reference r in
- try
- let kn = Nametab.locate_modtype qid in
- Feedback.msg_notice (Printmod.print_modtype kn)
- with Not_found ->
- (* Is there a module of this name ? If yes we display its type *)
- try
- let mp = Nametab.locate_module qid in
- Feedback.msg_notice (Printmod.print_module false mp)
- with Not_found ->
- Feedback.msg_error (str"Unknown Module Type or Module " ++ pr_qualid qid)
-
-let print_namespace ns =
- let ns = List.rev (Names.DirPath.repr ns) in
- (* [match_dirpath], [match_modulpath] are helpers for [matches]
- which checks whether a constant is in the namespace [ns]. *)
- let rec match_dirpath ns = function
- | [] -> Some ns
- | id::dir ->
- begin match match_dirpath ns dir with
- | Some [] as y -> y
- | Some (a::ns') ->
- if Names.Id.equal a id then Some ns'
- else None
- | None -> None
- end
- in
- let rec match_modulepath ns = function
- | MPbound _ -> None (* Not a proper namespace. *)
- | MPfile dir -> match_dirpath ns (Names.DirPath.repr dir)
- | MPdot (mp,lbl) ->
- let id = Names.Label.to_id lbl in
- begin match match_modulepath ns mp with
- | Some [] as y -> y
- | Some (a::ns') ->
- if Names.Id.equal a id then Some ns'
- else None
- | None -> None
- end
- in
- (* [qualified_minus n mp] returns a list of qualifiers representing
- [mp] except the [n] first (in the concrete syntax order). The
- idea is that if [mp] matches [ns], then [qualified_minus mp
- (length ns)] will be the correct representation of [mp] assuming
- [ns] is imported. *)
- (* precondition: [mp] matches some namespace of length [n] *)
- let qualified_minus n mp =
- let rec list_of_modulepath = function
- | MPbound _ -> assert false (* MPbound never matches *)
- | MPfile dir -> Names.DirPath.repr dir
- | MPdot (mp,lbl) -> (Names.Label.to_id lbl)::(list_of_modulepath mp)
- in
- snd (Util.List.chop n (List.rev (list_of_modulepath mp)))
- in
- let print_list pr l = prlist_with_sep (fun () -> str".") pr l in
- let print_kn kn =
- (* spiwack: I'm ignoring the dirpath, is that bad? *)
- let (mp,_,lbl) = Names.repr_kn kn in
- let qn = (qualified_minus (List.length ns) mp)@[Names.Label.to_id lbl] in
- print_list pr_id qn
- in
- let print_constant k body =
- (* FIXME: universes *)
- let t = Typeops.type_of_constant_type (Global.env ()) body.Declarations.const_type in
- print_kn k ++ str":" ++ spc() ++ Printer.pr_type t
- in
- let matches mp = match match_modulepath ns mp with
- | Some [] -> true
- | _ -> false in
- let constants = (Environ.pre_env (Global.env ())).Pre_env.env_globals.Pre_env.env_constants in
- let constants_in_namespace =
- Cmap_env.fold (fun c (body,_) acc ->
- let kn = user_con c in
- if matches (modpath kn) then
- acc++fnl()++hov 2 (print_constant kn body)
- else
- acc
- ) constants (str"")
- in
- Feedback.msg_notice ((print_list pr_id ns)++str":"++fnl()++constants_in_namespace)
-
-let print_strategy r =
- let open Conv_oracle in
- let pr_level = function
- | Expand -> str "expand"
- | Level 0 -> str "transparent"
- | Level n -> str "level" ++ spc() ++ int n
- | Opaque -> str "opaque"
- in
- let pr_strategy (ref, lvl) = pr_global ref ++ str " : " ++ pr_level lvl in
- let oracle = Environ.oracle (Global.env ()) in
- match r with
- | None ->
- let fold key lvl (vacc, cacc) = match key with
- | VarKey id -> ((VarRef id, lvl) :: vacc, cacc)
- | ConstKey cst -> (vacc, (ConstRef cst, lvl) :: cacc)
- | RelKey _ -> (vacc, cacc)
- in
- let var_lvl, cst_lvl = fold_strategy fold oracle ([], []) in
- let var_msg =
- if List.is_empty var_lvl then mt ()
- else str "Variable strategies" ++ fnl () ++
- hov 0 (prlist_with_sep fnl pr_strategy var_lvl) ++ fnl ()
- in
- let cst_msg =
- if List.is_empty cst_lvl then mt ()
- else str "Constant strategies" ++ fnl () ++
- hov 0 (prlist_with_sep fnl pr_strategy cst_lvl)
- in
- Feedback.msg_notice (var_msg ++ cst_msg)
- | Some r ->
- let r = Smartlocate.smart_global r in
- let key = match r with
- | VarRef id -> VarKey id
- | ConstRef cst -> ConstKey cst
- | IndRef _ | ConstructRef _ -> error "The reference is not unfoldable"
- in
- let lvl = get_strategy oracle key in
- Feedback.msg_notice (pr_strategy (r, lvl))
-
-let dump_universes_gen g s =
- let output = open_out s in
- let output_constraint, close =
- if Filename.check_suffix s ".dot" || Filename.check_suffix s ".gv" then begin
- (* the lazy unit is to handle errors while printing the first line *)
- let init = lazy (Printf.fprintf output "digraph universes {\n") in
- begin fun kind left right ->
- let () = Lazy.force init in
- match kind with
- | Univ.Lt ->
- Printf.fprintf output " \"%s\" -> \"%s\" [style=bold];\n" right left
- | Univ.Le ->
- Printf.fprintf output " \"%s\" -> \"%s\" [style=solid];\n" right left
- | Univ.Eq ->
- Printf.fprintf output " \"%s\" -> \"%s\" [style=dashed];\n" left right
- end, begin fun () ->
- if Lazy.is_val init then Printf.fprintf output "}\n";
- close_out output
- end
- end else begin
- begin fun kind left right ->
- let kind = match kind with
- | Univ.Lt -> "<"
- | Univ.Le -> "<="
- | Univ.Eq -> "="
- in Printf.fprintf output "%s %s %s ;\n" left kind right
- end, (fun () -> close_out output)
- end
- in
- try
- UGraph.dump_universes output_constraint g;
- close ();
- Feedback.msg_info (str "Universes written to file \"" ++ str s ++ str "\".")
- with reraise ->
- let reraise = CErrors.push reraise in
- close ();
- iraise reraise
-
-(*********************)
-(* "Locate" commands *)
-
-let locate_file f =
- let file = Flags.silently Loadpath.locate_file f in
- str file
-
-let msg_found_library = function
- | Library.LibLoaded, fulldir, file ->
- Feedback.msg_info (hov 0
- (pr_dirpath fulldir ++ strbrk " has been loaded from file " ++
- str file))
- | Library.LibInPath, fulldir, file ->
- Feedback.msg_info (hov 0
- (pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file))
-
-let err_unmapped_library loc ?from qid =
- let dir = fst (repr_qualid qid) in
- let prefix = match from with
- | None -> str "."
- | Some from ->
- str " and prefix " ++ pr_dirpath from ++ str "."
- in
- user_err_loc
- (loc,"locate_library",
- strbrk "Cannot find a physical path bound to logical path matching suffix " ++
- pr_dirpath dir ++ prefix)
-
-let err_notfound_library loc ?from qid =
- let prefix = match from with
- | None -> str "."
- | Some from ->
- str " with prefix " ++ pr_dirpath from ++ str "."
- in
- user_err_loc
- (loc,"locate_library",
- strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix)
-
-let print_located_library r =
- let (loc,qid) = qualid_of_reference r in
- try msg_found_library (Library.locate_qualified_library ~warn:false qid)
- with
- | Library.LibUnmappedDir -> err_unmapped_library loc qid
- | Library.LibNotFound -> err_notfound_library loc qid
-
-let smart_global r =
- let gr = Smartlocate.smart_global r in
- Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr;
- gr
-
-let dump_global r =
- try
- let gr = Smartlocate.smart_global r in
- Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr
- with e when CErrors.noncritical e -> ()
-(**********)
-(* Syntax *)
-
-let vernac_syntax_extension locality local =
- let local = enforce_module_locality locality local in
- Metasyntax.add_syntax_extension local
-
-let vernac_delimiters sc = function
- | Some lr -> Metasyntax.add_delimiters sc lr
- | None -> Metasyntax.remove_delimiters sc
-
-let vernac_bind_scope sc cll =
- Metasyntax.add_class_scope sc (List.map scope_class_of_qualid cll)
-
-let vernac_open_close_scope locality local (b,s) =
- let local = enforce_section_locality locality local in
- Notation.open_close_scope (local,b,s)
-
-let vernac_arguments_scope locality r scl =
- let local = make_section_locality locality in
- Notation.declare_arguments_scope local (smart_global r) scl
-
-let vernac_infix locality local =
- let local = enforce_module_locality locality local in
- Metasyntax.add_infix local
-
-let vernac_notation locality local =
- let local = enforce_module_locality locality local in
- Metasyntax.add_notation local
-
-(***********)
-(* Gallina *)
-
-let start_proof_and_print k l hook =
- let inference_hook =
- if Flags.is_program_mode () then
- let hook env sigma ev =
- let tac = !Obligations.default_tactic in
- let evi = Evd.find sigma ev in
- let env = Evd.evar_filtered_env evi in
- try
- let concl = Evarutil.nf_evars_universes sigma evi.Evd.evar_concl in
- if Evarutil.has_undefined_evars sigma concl then raise Exit;
- let c, _, ctx =
- Pfedit.build_by_tactic env (Evd.evar_universe_context sigma)
- concl (Tacticals.New.tclCOMPLETE tac)
- in Evd.set_universe_context sigma ctx, c
- with Logic_monad.TacticFailure e when Logic.catchable_exception e ->
- error "The statement obligations could not be resolved \
- automatically, write a statement definition first."
- in Some hook
- else None
- in
- start_proof_com ?inference_hook k l hook
-
-let no_hook = Lemmas.mk_hook (fun _ _ -> ())
-
-let vernac_definition_hook p = function
-| Coercion -> Class.add_coercion_hook p
-| CanonicalStructure ->
- Lemmas.mk_hook (fun _ -> Recordops.declare_canonical_structure)
-| SubClass -> Class.add_subclass_hook p
-| _ -> no_hook
-
-let vernac_definition locality p (local,k) ((loc,id as lid),pl) def =
- let local = enforce_locality_exp locality local in
- let hook = vernac_definition_hook p k in
- let () = match local with
- | Discharge -> Dumpglob.dump_definition lid true "var"
- | Local | Global -> Dumpglob.dump_definition lid false "def"
- in
- (match def with
- | ProveBody (bl,t) -> (* local binders, typ *)
- start_proof_and_print (local,p,DefinitionBody k)
- [Some (lid,pl), (bl,t,None)] hook
- | DefineBody (bl,red_option,c,typ_opt) ->
- let red_option = match red_option with
- | None -> None
- | Some r ->
- let (evc,env)= get_current_context () in
- Some (snd (Hook.get f_interp_redexp env evc r)) in
- do_definition id (local,p,k) pl bl red_option c typ_opt hook)
-
-let vernac_start_proof locality p kind l lettop =
- let local = enforce_locality_exp locality None in
- if Dumpglob.dump () then
- List.iter (fun (id, _) ->
- match id with
- | Some (lid,_) -> Dumpglob.dump_definition lid false "prf"
- | None -> ()) l;
- if not(refining ()) then
- if lettop then
- errorlabstrm "Vernacentries.StartProof"
- (str "Let declarations can only be used in proof editing mode.");
- start_proof_and_print (local, p, Proof kind) l no_hook
-
-let qed_display_script = ref true
-
-let vernac_end_proof ?proof = function
- | Admitted -> save_proof ?proof Admitted
- | Proved (_,_) as e ->
- if is_verbose () && !qed_display_script && !Flags.coqtop_ui then
- Stm.show_script ?proof ();
- save_proof ?proof e
-
- (* A stupid macro that should be replaced by ``Exact c. Save.'' all along
- the theories [??] *)
-
-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 = by (Tactics.exact_proof c) in
- save_proof (Vernacexpr.(Proved(Opaque None,None)));
- if not status then Feedback.feedback Feedback.AddedAxiom
-
-let vernac_assumption locality poly (local, kind) l nl =
- let local = enforce_locality_exp locality local in
- let global = local == Global in
- let kind = local, poly, kind in
- List.iter (fun (is_coe,(idl,c)) ->
- if Dumpglob.dump () then
- List.iter (fun (lid, _) ->
- if global then Dumpglob.dump_definition lid false "ax"
- else Dumpglob.dump_definition lid true "var") idl) l;
- let status = do_assumptions kind nl l in
- if not status then Feedback.feedback Feedback.AddedAxiom
-
-let vernac_record k poly finite struc binders sort nameopt cfs =
- let const = match nameopt with
- | None -> add_prefix "Build_" (snd (fst (snd struc)))
- | Some (_,id as lid) ->
- Dumpglob.dump_definition lid false "constr"; id in
- if Dumpglob.dump () then (
- Dumpglob.dump_definition (fst (snd struc)) false "rec";
- List.iter (fun (((_, x), _), _) ->
- match x with
- | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj"
- | _ -> ()) cfs);
- ignore(Record.definition_structure (k,poly,finite,struc,binders,cfs,const,sort))
-
-(** When [poly] is true the type is declared polymorphic. When [lo] is true,
- then the type is declared private (as per the [Private] keyword). [finite]
- indicates whether the type is inductive, co-inductive or
- neither. *)
-let vernac_inductive poly lo finite indl =
- if Dumpglob.dump () then
- List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) ->
- match cstrs with
- | Constructors cstrs ->
- Dumpglob.dump_definition lid false "ind";
- List.iter (fun (_, (lid, _)) ->
- Dumpglob.dump_definition lid false "constr") cstrs
- | _ -> () (* dumping is done by vernac_record (called below) *) )
- indl;
- match indl with
- | [ ( _ , _ , _ ,Record, Constructors _ ),_ ] ->
- CErrors.error "The Record keyword cannot be used to define a variant type. Use Variant instead."
- | [ (_ , _ , _ ,Variant, RecordDecl _),_ ] ->
- CErrors.error "The Variant keyword cannot be used to define a record type. Use Record instead."
- | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] ->
- vernac_record (match b with Class _ -> Class false | _ -> b)
- poly finite id bl c oc fs
- | [ ( id , bl , c , Class _, Constructors [l]), [] ] ->
- let f =
- let (coe, ((loc, id), ce)) = l in
- let coe' = if coe then Some true else None in
- (((coe', AssumExpr ((loc, Name id), ce)), None), [])
- in vernac_record (Class true) poly finite id bl c None [f]
- | [ ( _ , _, _, Class _, Constructors _), [] ] ->
- CErrors.error "Inductive classes not supported"
- | [ ( id , bl , c , Class _, _), _ :: _ ] ->
- CErrors.error "where clause not supported for classes"
- | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] ->
- CErrors.error "where clause not supported for (co)inductive records"
- | _ -> let unpack = function
- | ( (false, id) , bl , c , _ , Constructors l ) , ntn -> ( id , bl , c , l ) , ntn
- | ( (true,_),_,_,_,Constructors _),_ ->
- CErrors.error "Variant types do not handle the \"> Name\" syntax, which is reserved for records. Use the \":>\" syntax on constructors instead."
- | _ -> CErrors.error "Cannot handle mutually (co)inductive records."
- in
- let indl = List.map unpack indl in
- do_mutual_inductive indl poly lo finite
-
-let vernac_fixpoint locality poly local l =
- let local = enforce_locality_exp locality local in
- if Dumpglob.dump () then
- List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l;
- do_fixpoint local poly l
-
-let vernac_cofixpoint locality poly local l =
- let local = enforce_locality_exp locality local in
- if Dumpglob.dump () then
- List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l;
- do_cofixpoint local poly l
-
-let vernac_scheme l =
- if Dumpglob.dump () then
- List.iter (fun (lid, s) ->
- Option.iter (fun lid -> Dumpglob.dump_definition lid false "def") lid;
- match s with
- | InductionScheme (_, r, _)
- | CaseScheme (_, r, _)
- | EqualityScheme r -> dump_global r) l;
- Indschemes.do_scheme l
-
-let vernac_combined_scheme lid l =
- if Dumpglob.dump () then
- (Dumpglob.dump_definition lid false "def";
- List.iter (fun lid -> dump_global (Misctypes.AN (Ident lid))) l);
- Indschemes.do_combined_scheme lid l
-
-let vernac_universe loc poly l =
- if poly && not (Lib.sections_are_opened ()) then
- user_err_loc (loc, "vernac_universe",
- str"Polymorphic universes can only be declared inside sections, " ++
- str "use Monomorphic Universe instead");
- do_universe poly l
-
-let vernac_constraint loc poly l =
- if poly && not (Lib.sections_are_opened ()) then
- user_err_loc (loc, "vernac_constraint",
- str"Polymorphic universe constraints can only be declared"
- ++ str " inside sections, use Monomorphic Constraint instead");
- do_constraint poly l
-
-(**********************)
-(* Modules *)
-
-let vernac_import export refl =
- Library.import_module export (List.map qualid_of_reference refl);
- Lib.add_frozen_state ()
-
-let vernac_declare_module export (loc, id) binders_ast mty_ast =
- (* We check the state of the system (in section, in module type)
- and what module information is supplied *)
- if Lib.sections_are_opened () then
- error "Modules and Module Types are not allowed inside sections.";
- let binders_ast = List.map
- (fun (export,idl,ty) ->
- if not (Option.is_empty export) then
- error "Arguments of a functor declaration cannot be exported. Remove the \"Export\" and \"Import\" keywords from every functor argument."
- else (idl,ty)) binders_ast in
- let mp =
- Declaremods.declare_module Modintern.interp_module_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");
- Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export
-
-let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
- (* We check the state of the system (in section, in module type)
- and what module information is supplied *)
- if Lib.sections_are_opened () then
- error "Modules and Module Types are not allowed inside sections.";
- match mexpr_ast_l with
- | [] ->
- check_no_pending_proofs ();
- let binders_ast,argsexport =
- List.fold_right
- (fun (export,idl,ty) (args,argsexport) ->
- (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast
- ([],[]) in
- let mp =
- Declaremods.start_module Modintern.interp_module_ast
- export id binders_ast mty_ast_o
- in
- Dumpglob.dump_moddef loc mp "mod";
- if_verbose Feedback.msg_info
- (str "Interactive Module " ++ pr_id id ++ str " started");
- List.iter
- (fun (export,id) ->
- Option.iter
- (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export
- ) argsexport
- | _::_ ->
- let binders_ast = List.map
- (fun (export,idl,ty) ->
- if not (Option.is_empty export) then
- error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument."
- else (idl,ty)) binders_ast in
- let mp =
- Declaremods.declare_module Modintern.interp_module_ast
- id binders_ast mty_ast_o mexpr_ast_l
- in
- Dumpglob.dump_moddef loc mp "mod";
- if_verbose Feedback.msg_info
- (str "Module " ++ pr_id id ++ str " is defined");
- Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)])
- export
-
-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");
- Option.iter (fun export -> vernac_import export [Ident lid]) export
-
-let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
- if Lib.sections_are_opened () then
- error "Modules and Module Types are not allowed inside sections.";
-
- match mty_ast_l with
- | [] ->
- check_no_pending_proofs ();
- let binders_ast,argsexport =
- List.fold_right
- (fun (export,idl,ty) (args,argsexport) ->
- (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast
- ([],[]) in
-
- let mp =
- Declaremods.start_modtype Modintern.interp_module_ast
- id binders_ast mty_sign
- in
- Dumpglob.dump_moddef loc mp "modtype";
- if_verbose Feedback.msg_info
- (str "Interactive Module Type " ++ pr_id id ++ str " started");
- List.iter
- (fun (export,id) ->
- Option.iter
- (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export
- ) argsexport
-
- | _ :: _ ->
- let binders_ast = List.map
- (fun (export,idl,ty) ->
- if not (Option.is_empty export) then
- error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument."
- else (idl,ty)) binders_ast in
- let mp =
- Declaremods.declare_modtype Modintern.interp_module_ast
- id binders_ast mty_sign mty_ast_l
- in
- Dumpglob.dump_moddef loc mp "modtype";
- 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")
-
-let vernac_include l =
- Declaremods.declare_include Modintern.interp_module_ast l
-
-(**********************)
-(* Gallina extensions *)
-
-(* Sections *)
-
-let vernac_begin_section (_, id as lid) =
- check_no_pending_proofs ();
- Dumpglob.dump_definition lid true "sec";
- Lib.open_section id
-
-let vernac_end_section (loc,_) =
- Dumpglob.dump_reference loc
- (DirPath.to_string (Lib.current_dirpath true)) "<>" "sec";
- Lib.close_section ()
-
-let vernac_name_sec_hyp (_,id) set = Proof_using.name_set id set
-
-(* Dispatcher of the "End" command *)
-
-let vernac_end_segment (_,id as lid) =
- check_no_pending_proofs ();
- match Lib.find_opening_node id with
- | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid
- | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid
- | Lib.OpenedSection _ -> vernac_end_section lid
- | _ -> assert false
-
-(* Libraries *)
-
-let vernac_require from import qidl =
- let qidl = List.map qualid_of_reference qidl in
- let root = match from with
- | None -> None
- | Some from ->
- let (_, qid) = Libnames.qualid_of_reference from in
- let (hd, tl) = Libnames.repr_qualid qid in
- Some (Libnames.add_dirpath_suffix hd tl)
- in
- let locate (loc, qid) =
- try
- let warn = Flags.is_verbose () in
- let (_, dir, f) = Library.locate_qualified_library ?root ~warn qid in
- (dir, f)
- with
- | Library.LibUnmappedDir -> err_unmapped_library loc ?from:root qid
- | Library.LibNotFound -> err_notfound_library loc ?from:root qid
- in
- let modrefl = List.map locate qidl in
- if Dumpglob.dump () then
- List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl);
- Library.require_library_from_dirpath modrefl import
-
-(* Coercions and canonical structures *)
-
-let vernac_canonical r =
- Recordops.declare_canonical_structure (smart_global r)
-
-let vernac_coercion locality poly local ref qids qidt =
- let local = enforce_locality locality local in
- let target = cl_of_qualid qidt in
- 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")
-
-let vernac_identity_coercion locality poly local id qids qidt =
- let local = enforce_locality locality local in
- let target = cl_of_qualid qidt in
- let source = cl_of_qualid qids in
- Class.try_add_new_identity_coercion id ~local poly ~source ~target
-
-(* Type classes *)
-
-let vernac_instance abst locality poly sup inst props pri =
- let global = not (make_section_locality locality) in
- Dumpglob.dump_constraint inst false "inst";
- ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri)
-
-let vernac_context poly l =
- if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom
-
-let vernac_declare_instances locality insts =
- let glob = not (make_section_locality locality) in
- List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts
-
-let vernac_declare_class id =
- Record.declare_existing_class (Nametab.global id)
-
-(***********)
-(* Solving *)
-
-let command_focus = Proof.new_focus_kind ()
-let focus_command_cond = Proof.no_cond command_focus
-
- (* A command which should be a tactic. It has been
- added by Christine to patch an error in the design of the proof
- machine, and enables to instantiate existential variables when
- there are no more goals to solve. It cannot be a tactic since
- all tactics fail if there are no further goals to prove. *)
-
-let vernac_solve_existential = instantiate_nth_evar_com
-
-let vernac_set_end_tac tac =
- if not (refining ()) then
- error "Unknown command of the non proof-editing mode.";
- match tac with
- | Tacexpr.TacId [] -> ()
- | _ -> set_end_tac tac
- (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*)
-
-let vernac_set_used_variables e =
- let open Context.Named.Declaration in
- let env = Global.env () in
- let tys =
- List.map snd (Proof.initial_goals (Proof_global.give_me_the_proof ())) in
- let l = Proof_using.process_expr env e tys in
- let vars = Environ.named_context env in
- List.iter (fun id ->
- if not (List.exists (Id.equal id % get_id) vars) then
- errorlabstrm "vernac_set_used_variables"
- (str "Unknown variable: " ++ pr_id id))
- l;
- let _, to_clear = set_used_variables l in
- let to_clear = List.map snd to_clear in
- Proof_global.with_current_proof begin fun _ p ->
- if List.is_empty to_clear then (p, ())
- else
- let tac = Tactics.clear to_clear in
- fst (solve SelectAll None tac p), ()
- end
-
-(*****************************)
-(* Auxiliary file management *)
-
-let expand filename =
- Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) filename
-
-let vernac_add_loadpath implicit pdir ldiropt =
- let pdir = expand pdir in
- let alias = Option.default Nameops.default_root_prefix ldiropt in
- Mltop.add_rec_path Mltop.AddTopML ~unix_path:pdir ~coq_root:alias ~implicit
-
-let vernac_remove_loadpath path =
- Loadpath.remove_load_path (expand path)
-
- (* Coq syntax for ML or system commands *)
-
-let vernac_add_ml_path isrec path =
- (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (expand path)
-
-let vernac_declare_ml_module locality l =
- let local = make_locality locality in
- Mltop.declare_ml_modules local (List.map expand l)
-
-let vernac_chdir = function
- | None -> Feedback.msg_notice (str (Sys.getcwd()))
- | Some path ->
- begin
- try Sys.chdir (expand path)
- with Sys_error err ->
- (* Cd is typically used to control the output directory of
- extraction. A failed Cd could lead to overwriting .ml files
- so we make it an error. *)
- CErrors.error ("Cd failed: " ^ err)
- end;
- if_verbose Feedback.msg_info (str (Sys.getcwd()))
-
-
-(********************)
-(* State management *)
-
-let vernac_write_state file =
- Pfedit.delete_all_proofs ();
- let file = CUnix.make_suffix file ".coq" in
- States.extern_state file
-
-let vernac_restore_state file =
- Pfedit.delete_all_proofs ();
- let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in
- States.intern_state file
-
-(************)
-(* Commands *)
-
-let vernac_create_hintdb locality id b =
- let local = make_module_locality locality in
- Hints.create_hint_db local id full_transparent_state b
-
-let vernac_remove_hints locality dbs ids =
- let local = make_module_locality locality in
- Hints.remove_hints local dbs (List.map Smartlocate.global_with_alias ids)
-
-let vernac_hints locality poly local lb h =
- let local = enforce_module_locality locality local in
- Hints.add_hints local lb (Hints.interp_hints poly 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
-
-let vernac_declare_implicits locality r l =
- let local = make_section_locality locality in
- match l with
- | [] ->
- Impargs.declare_implicits local (smart_global r)
- | _::_ as imps ->
- Impargs.declare_manual_implicits local (smart_global r) ~enriching:false
- (List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps)
-
-let warn_arguments_assert =
- CWarnings.create ~name:"arguments-assert" ~category:"vernacular"
- (fun sr ->
- strbrk "This command is just asserting the names of arguments of " ++
- pr_global sr ++ strbrk". If this is what you want add " ++
- strbrk "': assert' to silence the warning. If you want " ++
- strbrk "to clear implicit arguments add ': clear implicits'. " ++
- strbrk "If you want to clear notation scopes add ': clear scopes'")
-
-(* [nargs_for_red] is the number of arguments required to trigger reduction,
- [args] is the main list of arguments statuses,
- [more_implicits] is a list of extra lists of implicit statuses *)
-let vernac_arguments locality reference args more_implicits nargs_for_red flags =
- let assert_flag = List.mem `Assert flags in
- let rename_flag = List.mem `Rename flags in
- let clear_scopes_flag = List.mem `ClearScopes flags in
- let extra_scopes_flag = List.mem `ExtraScopes flags in
- let clear_implicits_flag = List.mem `ClearImplicits flags in
- let default_implicits_flag = List.mem `DefaultImplicits flags in
- let never_unfold_flag = List.mem `ReductionNeverUnfold flags in
-
- let err_incompat x y =
- error ("Options \""^x^"\" and \""^y^"\" are incompatible.") in
-
- if assert_flag && rename_flag then
- err_incompat "assert" "rename";
- if Option.has_some nargs_for_red && never_unfold_flag then
- err_incompat "simpl never" "/";
- if never_unfold_flag && List.mem `ReductionDontExposeCase flags then
- err_incompat "simpl never" "simpl nomatch";
- if clear_scopes_flag && extra_scopes_flag then
- err_incompat "clear scopes" "extra scopes";
- if clear_implicits_flag && default_implicits_flag then
- err_incompat "clear implicits" "default implicits";
-
- let sr = smart_global reference in
- let inf_names =
- let ty = Global.type_of_global_unsafe sr in
- Impargs.compute_implicits_names (Global.env ()) ty
- in
- let prev_names =
- try Arguments_renaming.arguments_names sr with Not_found -> inf_names
- in
- let num_args = List.length inf_names in
- assert (Int.equal num_args (List.length prev_names));
-
- let names_of args = List.map (fun a -> a.name) args in
-
- (* Checks *)
-
- let err_extra_args names =
- errorlabstrm "vernac_declare_arguments"
- (strbrk "Extra arguments: " ++
- prlist_with_sep pr_comma pr_name names ++ str ".")
- in
- let err_missing_args names =
- errorlabstrm "vernac_declare_arguments"
- (strbrk "The following arguments are not declared: " ++
- prlist_with_sep pr_comma pr_name names ++ str ".")
- in
-
- let rec check_extra_args extra_args =
- match extra_args with
- | [] -> ()
- | { notation_scope = None } :: _ -> err_extra_args (names_of extra_args)
- | { name = Anonymous; notation_scope = Some _ } :: args ->
- check_extra_args args
- | _ ->
- error "Extra notation scopes can be set on anonymous and explicit arguments only."
- in
-
- let args, scopes =
- let scopes = List.map (fun { notation_scope = s } -> s) args in
- if List.length args > num_args then
- let args, extra_args = List.chop num_args args in
- if extra_scopes_flag then
- (check_extra_args extra_args; (args, scopes))
- else err_extra_args (names_of extra_args)
- else args, scopes
- in
-
- if Option.cata (fun n -> n > num_args) false nargs_for_red then
- error "The \"/\" modifier should be put before any extra scope.";
-
- let scopes_specified = List.exists Option.has_some scopes in
-
- if scopes_specified && clear_scopes_flag then
- error "The \"clear scopes\" flag is incompatible with scope annotations.";
-
- let names = List.map (fun { name } -> name) args in
- let names = names :: List.map (List.map fst) more_implicits in
-
- let rename_flag_required = ref false in
- let example_renaming = ref None in
- let save_example_renaming renaming =
- rename_flag_required := !rename_flag_required
- || not (Name.equal (fst renaming) Anonymous);
- if Option.is_empty !example_renaming then
- example_renaming := Some renaming
- in
-
- let rec names_union names1 names2 =
- match names1, names2 with
- | [], [] -> []
- | _ :: _, [] -> names1
- | [], _ :: _ -> names2
- | (Name _ as name) :: names1, Anonymous :: names2
- | Anonymous :: names1, (Name _ as name) :: names2 ->
- name :: names_union names1 names2
- | name1 :: names1, name2 :: names2 ->
- if Name.equal name1 name2 then
- name1 :: names_union names1 names2
- else error "Argument lists should agree on the names they provide."
- in
-
- let names = List.fold_left names_union [] names in
-
- let rec rename prev_names names =
- match prev_names, names with
- | [], [] -> []
- | [], _ :: _ -> err_extra_args names
- | _ :: _, [] when assert_flag ->
- (* Error messages are expressed in terms of original names, not
- renamed ones. *)
- err_missing_args (List.lastn (List.length prev_names) inf_names)
- | _ :: _, [] -> prev_names
- | prev :: prev_names, Anonymous :: names ->
- prev :: rename prev_names names
- | prev :: prev_names, (Name id as name) :: names ->
- if not (Name.equal prev name) then save_example_renaming (prev,name);
- name :: rename prev_names names
- in
-
- let names = rename prev_names names in
- let renaming_specified = Option.has_some !example_renaming in
-
- if !rename_flag_required && not rename_flag then
- errorlabstrm "vernac_declare_arguments"
- (strbrk "To rename arguments the \"rename\" flag must be specified."
- ++ spc () ++
- match !example_renaming with
- | None -> mt ()
- | Some (o,n) ->
- str "Argument " ++ pr_name o ++
- str " renamed to " ++ pr_name n ++ str ".");
-
- let duplicate_names =
- List.duplicates Name.equal (List.filter ((!=) Anonymous) names)
- in
- if not (List.is_empty duplicate_names) then begin
- let duplicates = prlist_with_sep pr_comma pr_name duplicate_names in
- errorlabstrm "_" (strbrk "Some argument names are duplicated: " ++ duplicates)
- end;
-
- (* Parts of this code are overly complicated because the implicit arguments
- API is completely crazy: positions (ExplByPos) are elaborated to
- names. This is broken by design, since not all arguments have names. So
- even though we eventually want to map only positions to implicit statuses,
- we have to check whether the corresponding arguments have names, not to
- trigger an error in the impargs code. Even better, the names we have to
- check are not the current ones (after previous renamings), but the original
- ones (inferred from the type). *)
-
- let implicits =
- List.map (fun { name; implicit_status = i } -> (name,i)) args
- in
- let implicits = implicits :: more_implicits in
-
- let open Vernacexpr in
- let rec build_implicits inf_names implicits =
- match inf_names, implicits with
- | _, [] -> []
- | _ :: inf_names, (_, NotImplicit) :: implicits ->
- build_implicits inf_names implicits
-
- (* With the current impargs API, it is impossible to make an originally
- anonymous argument implicit *)
- | Anonymous :: _, (name, _) :: _ ->
- errorlabstrm "vernac_declare_arguments"
- (strbrk"Argument "++ pr_name name ++
- strbrk " cannot be declared implicit.")
-
- | Name id :: inf_names, (name, impl) :: implicits ->
- let max = impl = MaximallyImplicit in
- (ExplByName id,max,false) :: build_implicits inf_names implicits
-
- | _ -> assert false (* already checked in [names_union] *)
- in
-
- let implicits = List.map (build_implicits inf_names) implicits in
- let implicits_specified = match implicits with [[]] -> false | _ -> true in
-
- if implicits_specified && clear_implicits_flag then
- error "The \"clear implicits\" flag is incompatible with implicit annotations";
-
- if implicits_specified && default_implicits_flag then
- error "The \"default implicits\" flag is incompatible with implicit annotations";
-
- let rargs =
- Util.List.map_filter (function (n, true) -> Some n | _ -> None)
- (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args)
- in
-
- let rec narrow = function
- | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl
- | [] -> [] | _ :: tl -> narrow tl
- in
- let red_flags = narrow flags in
- let red_modifiers_specified =
- not (List.is_empty rargs) || Option.has_some nargs_for_red
- || not (List.is_empty red_flags)
- in
-
- if not (List.is_empty rargs) && never_unfold_flag then
- err_incompat "simpl never" "!";
-
-
- (* Actions *)
-
- if renaming_specified then begin
- let local = make_section_locality locality in
- Arguments_renaming.rename_arguments local sr names
- end;
-
- if scopes_specified || clear_scopes_flag then begin
- let scopes = List.map (Option.map (fun (o,k) ->
- try ignore (Notation.find_scope k); k
- with UserError _ ->
- Notation.find_delimiters_scope o k)) scopes
- in
- vernac_arguments_scope locality reference scopes
- end;
-
- if implicits_specified || clear_implicits_flag then
- vernac_declare_implicits locality reference implicits;
-
- if default_implicits_flag then
- vernac_declare_implicits locality reference [];
-
- if red_modifiers_specified then begin
- match sr with
- | ConstRef _ as c ->
- Reductionops.ReductionBehaviour.set
- (make_section_locality locality) c
- (rargs, Option.default ~-1 nargs_for_red, red_flags)
- | _ -> errorlabstrm ""
- (strbrk "Modifiers of the behavior of the simpl tactic "++
- strbrk "are relevant for constants only.")
- end;
-
- if not (renaming_specified ||
- implicits_specified ||
- scopes_specified ||
- red_modifiers_specified) && (List.is_empty flags) then
- warn_arguments_assert sr
-
-let default_env () = {
- Notation_term.ninterp_var_type = Id.Map.empty;
- ninterp_rec_vars = Id.Map.empty;
-}
-
-let vernac_reserve bl =
- let sb_decl = (fun (idl,c) ->
- 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) 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
-
-let vernac_generalizable locality =
- let local = make_non_locality locality in
- Implicit_quantifiers.declare_generalizable local
-
-let _ =
- declare_bool_option
- { optsync = false;
- optdepr = false;
- optname = "silent";
- optkey = ["Silent"];
- optread = is_silent;
- optwrite = make_silent }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "implicit arguments";
- optkey = ["Implicit";"Arguments"];
- optread = Impargs.is_implicit_args;
- optwrite = Impargs.make_implicit_args }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "strict implicit arguments";
- optkey = ["Strict";"Implicit"];
- optread = Impargs.is_strict_implicit_args;
- optwrite = Impargs.make_strict_implicit_args }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "strong strict implicit arguments";
- optkey = ["Strongly";"Strict";"Implicit"];
- optread = Impargs.is_strongly_strict_implicit_args;
- optwrite = Impargs.make_strongly_strict_implicit_args }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "contextual implicit arguments";
- optkey = ["Contextual";"Implicit"];
- optread = Impargs.is_contextual_implicit_args;
- optwrite = Impargs.make_contextual_implicit_args }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "implicit status of reversible patterns";
- optkey = ["Reversible";"Pattern";"Implicit"];
- optread = Impargs.is_reversible_pattern_implicit_args;
- optwrite = Impargs.make_reversible_pattern_implicit_args }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "maximal insertion of implicit";
- optkey = ["Maximal";"Implicit";"Insertion"];
- optread = Impargs.is_maximal_implicit_args;
- optwrite = Impargs.make_maximal_implicit_args }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "automatic introduction of variables";
- optkey = ["Automatic";"Introduction"];
- optread = Flags.is_auto_intros;
- optwrite = make_auto_intros }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "coercion printing";
- optkey = ["Printing";"Coercions"];
- optread = (fun () -> !Constrextern.print_coercions);
- optwrite = (fun b -> Constrextern.print_coercions := b) }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "printing of existential variable instances";
- optkey = ["Printing";"Existential";"Instances"];
- optread = (fun () -> !Detyping.print_evar_arguments);
- optwrite = (:=) Detyping.print_evar_arguments }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "implicit arguments printing";
- optkey = ["Printing";"Implicit"];
- optread = (fun () -> !Constrextern.print_implicits);
- optwrite = (fun b -> Constrextern.print_implicits := b) }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "implicit arguments defensive printing";
- optkey = ["Printing";"Implicit";"Defensive"];
- optread = (fun () -> !Constrextern.print_implicits_defensive);
- optwrite = (fun b -> Constrextern.print_implicits_defensive := b) }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "projection printing using dot notation";
- optkey = ["Printing";"Projections"];
- optread = (fun () -> !Constrextern.print_projections);
- optwrite = (fun b -> Constrextern.print_projections := b) }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "notations printing";
- optkey = ["Printing";"Notations"];
- optread = (fun () -> not !Constrextern.print_no_symbol);
- optwrite = (fun b -> Constrextern.print_no_symbol := not b) }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "raw printing";
- optkey = ["Printing";"All"];
- optread = (fun () -> !Flags.raw_print);
- optwrite = (fun b -> Flags.raw_print := b) }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "record printing";
- optkey = ["Printing";"Records"];
- optread = (fun () -> !Flags.record_print);
- optwrite = (fun b -> Flags.record_print := b) }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "use of the program extension";
- optkey = ["Program";"Mode"];
- optread = (fun () -> !Flags.program_mode);
- optwrite = (fun b -> Flags.program_mode:=b) }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "universe polymorphism";
- optkey = ["Universe"; "Polymorphism"];
- optread = Flags.is_universe_polymorphism;
- optwrite = Flags.make_universe_polymorphism }
-
-let _ =
- declare_int_option
- { optsync = true;
- optdepr = false;
- optname = "the level of inlining during functor application";
- optkey = ["Inline";"Level"];
- optread = (fun () -> Some (Flags.get_inline_level ()));
- optwrite = (fun o ->
- let lev = Option.default Flags.default_inline_level o in
- Flags.set_inline_level lev) }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "kernel term sharing";
- optkey = ["Kernel"; "Term"; "Sharing"];
- optread = (fun () -> !CClosure.share);
- optwrite = (fun b -> CClosure.share := b) }
-
-(* No more undo limit in the new proof engine.
- The command still exists for compatibility (e.g. with ProofGeneral) *)
-
-let _ =
- declare_int_option
- { optsync = false;
- optdepr = true;
- optname = "the undo limit (OBSOLETE)";
- optkey = ["Undo"];
- optread = (fun _ -> None);
- optwrite = (fun _ -> ()) }
-
-let _ =
- declare_int_option
- { optsync = false;
- optdepr = false;
- optname = "the hypotheses limit";
- optkey = ["Hyps";"Limit"];
- optread = Flags.print_hyps_limit;
- optwrite = Flags.set_print_hyps_limit }
-
-let _ =
- declare_int_option
- { optsync = true;
- optdepr = false;
- optname = "the printing depth";
- optkey = ["Printing";"Depth"];
- optread = Pp_control.get_depth_boxes;
- optwrite = Pp_control.set_depth_boxes }
-
-let _ =
- declare_int_option
- { optsync = true;
- optdepr = false;
- optname = "the printing width";
- optkey = ["Printing";"Width"];
- optread = Pp_control.get_margin;
- optwrite = Pp_control.set_margin }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "printing of universes";
- optkey = ["Printing";"Universes"];
- optread = (fun () -> !Constrextern.print_universes);
- optwrite = (fun b -> Constrextern.print_universes:=b) }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "dumping bytecode after compilation";
- optkey = ["Dump";"Bytecode"];
- optread = Flags.get_dump_bytecode;
- optwrite = Flags.set_dump_bytecode }
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "explicitly parsing implicit arguments";
- optkey = ["Parsing";"Explicit"];
- optread = (fun () -> !Constrintern.parsing_explicit);
- optwrite = (fun b -> Constrintern.parsing_explicit := b) }
-
-let _ =
- declare_string_option ~preprocess:CWarnings.normalize_flags_string
- { optsync = true;
- optdepr = false;
- optname = "warnings display";
- optkey = ["Warnings"];
- optread = CWarnings.get_flags;
- optwrite = CWarnings.set_flags }
-
-let vernac_set_strategy locality l =
- let local = make_locality locality in
- let glob_ref r =
- match smart_global r with
- | ConstRef sp -> EvalConstRef sp
- | VarRef id -> EvalVarRef id
- | _ -> error
- "cannot set an inductive type or a constructor as transparent" in
- let l = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) l in
- Redexpr.set_strategy local l
-
-let vernac_set_opacity locality (v,l) =
- let local = make_non_locality locality in
- let glob_ref r =
- match smart_global r with
- | ConstRef sp -> EvalConstRef sp
- | VarRef id -> EvalVarRef id
- | _ -> error
- "cannot set an inductive type or a constructor as transparent" in
- let l = List.map glob_ref l in
- Redexpr.set_strategy local [v,l]
-
-let vernac_set_option locality key = function
- | StringValue s -> set_string_option_value_gen locality key s
- | StringOptValue (Some s) -> set_string_option_value_gen locality key s
- | StringOptValue None -> unset_option_value_gen locality key
- | IntValue n -> set_int_option_value_gen locality key n
- | BoolValue b -> set_bool_option_value_gen locality key b
-
-let vernac_set_append_option locality key s =
- set_string_option_append_value_gen locality key s
-
-let vernac_unset_option locality key =
- unset_option_value_gen locality key
-
-let vernac_add_option key lv =
- let f = function
- | StringRefValue s -> (get_string_table key)#add s
- | QualidRefValue locqid -> (get_ref_table key)#add locqid
- in
- try List.iter f lv with Not_found -> error_undeclared_key key
-
-let vernac_remove_option key lv =
- let f = function
- | StringRefValue s -> (get_string_table key)#remove s
- | QualidRefValue locqid -> (get_ref_table key)#remove locqid
- in
- try List.iter f lv with Not_found -> error_undeclared_key key
-
-let vernac_mem_option key lv =
- let f = function
- | StringRefValue s -> (get_string_table key)#mem s
- | QualidRefValue locqid -> (get_ref_table key)#mem locqid
- in
- try List.iter f lv with Not_found -> error_undeclared_key key
-
-let vernac_print_option key =
- try (get_ref_table key)#print
- with Not_found ->
- try (get_string_table key)#print
- with Not_found ->
- try print_option_value key
- with Not_found -> error_undeclared_key key
-
-let get_current_context_of_args = function
- | Some n -> get_goal_context n
- | None -> get_current_context ()
-
-let vernac_check_may_eval redexp glopt rc =
- let (sigma, env) = get_current_context_of_args glopt in
- let sigma', c = interp_open_constr env sigma rc in
- 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 env = Environ.push_context uctx (Evarutil.nf_env_evar sigma' env) in
- let c = nf c in
- let j =
- if Evarutil.has_undefined_evars sigma' c then
- Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' c)
- else
- (* OK to call kernel which does not support evars *)
- Arguments_renaming.rename_typing env c in
- match redexp with
- | None ->
- let l = Evar.Set.union (Evd.evars_of_term j.Environ.uj_val) (Evd.evars_of_term j.Environ.uj_type) in
- let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in
- Feedback.msg_notice (print_judgment env sigma' j ++
- pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++
- Printer.pr_universe_ctx sigma uctx)
- | Some r ->
- let (sigma',r_interp) = Hook.get f_interp_redexp env sigma' r in
- let redfun env evm c =
- let (redfun, _) = reduction_of_red_expr env r_interp in
- let evm = Sigma.Unsafe.of_evar_map evm in
- let Sigma (c, _, _) = redfun.Reductionops.e_redfun env evm c in
- c
- in
- Feedback.msg_notice (print_eval redfun env sigma' rc j)
-
-let vernac_declare_reduction locality s r =
- let local = make_locality locality in
- declare_red_expr local s (snd (Hook.get f_interp_redexp (Global.env()) Evd.empty r))
-
- (* The same but avoiding the current goal context if any *)
-let vernac_global_check c =
- let env = Global.env() in
- let sigma = Evd.from_env env in
- let c,ctx = interp_constr env sigma c in
- let senv = Global.safe_env() in
- let cstrs = snd (UState.context_set ctx) in
- let senv = Safe_typing.add_constraints cstrs senv in
- let j = Safe_typing.typing senv c in
- let env = Safe_typing.env_of_safe_env senv in
- Feedback.msg_notice (print_safe_judgment env sigma j)
-
-
-let get_nth_goal n =
- let pf = get_pftreestate() in
- let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in
- let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in
- gl
-
-exception NoHyp
-(* Printing "About" information of a hypothesis of the current goal.
- We only print the type and a small statement to this comes from the
- goal. Precondition: there must be at least one current goal. *)
-let print_about_hyp_globs ref_or_by_not glnumopt =
- let open Context.Named.Declaration in
- try
- let gl,id =
- match glnumopt,ref_or_by_not with
- | None,AN (Ident (_loc,id)) -> (* goal number not given, catch any failure *)
- (try get_nth_goal 1,id with _ -> raise NoHyp)
- | Some n,AN (Ident (_loc,id)) -> (* goal number given, catch if wong *)
- (try get_nth_goal n,id
- with
- Failure _ -> errorlabstrm "print_about_hyp_globs"
- (str "No such goal: " ++ int n ++ str "."))
- | _ , _ -> raise NoHyp in
- let hyps = pf_hyps gl in
- let decl = Context.Named.lookup id hyps in
- let natureofid = match decl with
- | LocalAssum _ -> "Hypothesis"
- | LocalDef (_,bdy,_) ->"Constant (let in)" in
- v 0 (pr_id id ++ str":" ++ pr_constr (get_type decl) ++ fnl() ++ fnl()
- ++ str natureofid ++ str " of the goal context.")
- with (* fallback to globals *)
- | NoHyp | Not_found -> print_about ref_or_by_not
-
-
-let vernac_print = let open Feedback in function
- | PrintTables -> msg_notice (print_tables ())
- | PrintFullContext-> msg_notice (print_full_context_typ ())
- | PrintSectionContext qid -> msg_notice (print_sec_context_typ qid)
- | PrintInspect n -> msg_notice (inspect n)
- | PrintGrammar ent -> msg_notice (Metasyntax.pr_grammar ent)
- | PrintLoadPath dir -> (* For compatibility ? *) msg_notice (print_loadpath dir)
- | PrintModules -> msg_notice (print_modules ())
- | PrintModule qid -> print_module qid
- | PrintModuleType qid -> print_modtype qid
- | PrintNamespace ns -> print_namespace ns
- | PrintMLLoadPath -> msg_notice (Mltop.print_ml_path ())
- | PrintMLModules -> msg_notice (Mltop.print_ml_modules ())
- | PrintDebugGC -> msg_notice (Mltop.print_gc ())
- | PrintName qid -> dump_global qid; msg_notice (print_name qid)
- | PrintGraph -> msg_notice (Prettyp.print_graph())
- | PrintClasses -> msg_notice (Prettyp.print_classes())
- | PrintTypeClasses -> msg_notice (Prettyp.print_typeclasses())
- | PrintInstances c -> msg_notice (Prettyp.print_instances (smart_global c))
- | PrintCoercions -> msg_notice (Prettyp.print_coercions())
- | PrintCoercionPaths (cls,clt) ->
- msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt))
- | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ())
- | PrintUniverses (b, dst) ->
- let univ = Global.universes () in
- let univ = if b then UGraph.sort_universes univ else univ in
- let pr_remaining =
- if Global.is_joined_environment () then mt ()
- else str"There may remain asynchronous universe constraints"
- in
- begin match dst with
- | None -> msg_notice (UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining)
- | Some s -> dump_universes_gen univ s
- end
- | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r))
- | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ())
- | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name s)
- | PrintHintDb -> msg_notice (Hints.pr_searchtable ())
- | PrintScopes ->
- msg_notice (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr))
- | PrintScope s ->
- msg_notice (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s)
- | PrintVisibility s ->
- msg_notice (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s)
- | PrintAbout (ref_or_by_not,glnumopt) ->
- msg_notice (print_about_hyp_globs ref_or_by_not glnumopt)
- | PrintImplicit qid ->
- dump_global qid; msg_notice (print_impargs qid)
- | PrintAssumptions (o,t,r) ->
- (* Prints all the axioms and section variables used by a term *)
- let gr = smart_global r in
- let cstr = printable_constr_of_global gr in
- let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in
- let nassums =
- Assumptions.assumptions st ~add_opaque:o ~add_transparent:t gr cstr in
- msg_notice (Printer.pr_assumptionset (Global.env ()) nassums)
- | PrintStrategy r -> print_strategy r
-
-let global_module r =
- let (loc,qid) = qualid_of_reference r in
- try Nametab.full_name_module qid
- with Not_found ->
- user_err_loc (loc, "global_module",
- str "Module/section " ++ pr_qualid qid ++ str " not found.")
-
-let interp_search_restriction = function
- | SearchOutside l -> (List.map global_module l, true)
- | SearchInside l -> (List.map global_module l, false)
-
-open Search
-
-let interp_search_about_item env =
- function
- | SearchSubPattern pat ->
- let _,pat = intern_constr_pattern env pat in
- GlobSearchSubPattern pat
- | SearchString (s,None) when Id.is_valid s ->
- GlobSearchString s
- | SearchString (s,sc) ->
- try
- let ref =
- Notation.interp_notation_as_global_reference Loc.ghost
- (fun _ -> true) s sc in
- GlobSearchSubPattern (Pattern.PRef ref)
- with UserError _ ->
- errorlabstrm "interp_search_about_item"
- (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component")
-
-(* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the
- `search_output_name_only` option to avoid excessive printing when
- searching.
-
- The motivation was to make search usable for IDE completion,
- however, it is still too slow due to the non-indexed nature of the
- underlying search mechanism.
-
- In the future we should deprecate the option and provide a fast,
- indexed name-searching interface.
-*)
-let search_output_name_only = ref false
-
-let _ =
- declare_bool_option
- { optsync = true;
- optdepr = false;
- optname = "output-name-only search";
- optkey = ["Search";"Output";"Name";"Only"];
- optread = (fun () -> !search_output_name_only);
- optwrite = (:=) search_output_name_only }
-
-let vernac_search s gopt r =
- let r = interp_search_restriction r in
- let env,gopt =
- match gopt with | None ->
- (* 1st goal by default if it exists, otherwise no goal at all *)
- (try snd (Pfedit.get_goal_context 1) , Some 1
- with _ -> Global.env (),None)
- (* if goal selector is given and wrong, then let exceptions be raised. *)
- | Some g -> snd (Pfedit.get_goal_context g) , Some g
- in
- let get_pattern c = snd (intern_constr_pattern env c) in
- let pr_search ref env c =
- let pr = pr_global ref in
- let pp = if !search_output_name_only
- then pr
- else begin
- let pc = pr_lconstr_env env Evd.empty c in
- hov 2 (pr ++ str":" ++ spc () ++ pc)
- end
- in Feedback.msg_notice pp
- in
- match s with
- | SearchPattern c ->
- Search.search_pattern gopt (get_pattern c) r pr_search
- | SearchRewrite c ->
- Search.search_rewrite gopt (get_pattern c) r pr_search
- | SearchHead c ->
- Search.search_by_head gopt (get_pattern c) r pr_search
- | SearchAbout sl ->
- Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r pr_search
-
-let vernac_locate = let open Feedback in function
- | LocateAny (AN qid) -> msg_notice (print_located_qualid qid)
- | LocateTerm (AN qid) -> msg_notice (print_located_term qid)
- | LocateAny (ByNotation (_, ntn, sc)) (** TODO : handle Ltac notations *)
- | LocateTerm (ByNotation (_, ntn, sc)) ->
- msg_notice
- (Notation.locate_notation
- (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)
- | LocateFile f -> msg_notice (locate_file f)
-
-let vernac_register id r =
- if Pfedit.refining () then
- error "Cannot register a primitive while in proof editing mode.";
- let t = (Constrintern.global_reference (snd id)) in
- if not (isConst t) then
- error "Register inline: a constant is expected";
- let kn = destConst t in
- match r with
- | RegisterInline -> Global.register_inline (Univ.out_punivs kn)
-
-(********************)
-(* Proof management *)
-
-let vernac_focus gln =
- Proof_global.simple_with_current_proof (fun _ p ->
- match gln with
- | None -> Proof.focus focus_command_cond () 1 p
- | Some 0 ->
- CErrors.error "Invalid goal number: 0. Goal numbering starts with 1."
- | Some n ->
- Proof.focus focus_command_cond () n p)
-
- (* Unfocuses one step in the focus stack. *)
-let vernac_unfocus () =
- Proof_global.simple_with_current_proof
- (fun _ p -> Proof.unfocus command_focus p ())
-
-(* Checks that a proof is fully unfocused. Raises an error if not. *)
-let vernac_unfocused () =
- let p = Proof_global.give_me_the_proof () in
- if Proof.unfocused p then
- Feedback.msg_notice (str"The proof is indeed fully unfocused.")
- else
- error "The proof is not fully unfocused."
-
-
-(* BeginSubproof / EndSubproof.
- BeginSubproof (vernac_subproof) focuses on the first goal, or the goal
- given as argument.
- EndSubproof (vernac_end_subproof) unfocuses from a BeginSubproof, provided
- that the proof of the goal has been completed.
-*)
-let subproof_kind = Proof.new_focus_kind ()
-let subproof_cond = Proof.done_cond subproof_kind
-
-let vernac_subproof gln =
- Proof_global.simple_with_current_proof (fun _ p ->
- match gln with
- | None -> Proof.focus subproof_cond () 1 p
- | Some n -> Proof.focus subproof_cond () n p)
-
-let vernac_end_subproof () =
- Proof_global.simple_with_current_proof (fun _ p ->
- Proof.unfocus subproof_kind p ())
-
-let vernac_bullet (bullet:Proof_global.Bullet.t) =
- Proof_global.simple_with_current_proof (fun _ p ->
- Proof_global.Bullet.put p bullet)
-
-let vernac_show = let open Feedback in function
- | ShowGoal goalref ->
- let info = match goalref with
- | 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
- | ShowGoalImplicitly None ->
- Constrextern.with_implicits msg_notice (pr_open_subgoals ())
- | ShowGoalImplicitly (Some n) ->
- Constrextern.with_implicits msg_notice (pr_nth_open_subgoal n)
- | ShowProof -> show_proof ()
- | ShowNode -> show_node ()
- | ShowScript -> Stm.show_script ()
- | ShowExistentials -> show_top_evars ()
- | ShowUniverses -> show_universes ()
- | ShowTree -> show_prooftree ()
- | ShowProofNames ->
- msg_notice (pr_sequence pr_id (Pfedit.get_all_proof_names()))
- | ShowIntros all -> show_intro all
- | ShowMatch id -> show_match id
- | ShowThesis -> show_thesis ()
-
-
-let vernac_check_guard () =
- let pts = get_pftreestate () in
- let pfterm = List.hd (Proof.partial_proof pts) in
- let message =
- try
- let { Evd.it=gl ; sigma=sigma } = Proof.V82.top_goal pts in
- Inductiveops.control_only_guard (Goal.V82.env sigma gl)
- pfterm;
- (str "The condition holds up to here")
- with UserError(_,s) ->
- (str ("Condition violated: ") ++s)
- in
- Feedback.msg_notice message
-
-exception End_of_input
-
-let vernac_load interp fname =
- let interp x =
- let proof_mode = Proof_global.get_default_proof_mode_name () in
- Proof_global.activate_proof_mode proof_mode;
- interp x in
- let parse_sentence = Flags.with_option Flags.we_are_parsing
- (fun po ->
- match Pcoq.Gram.entry_parse Pcoq.main_entry po with
- | Some x -> x
- | None -> raise End_of_input) in
- let fname =
- Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in
- let fname = CUnix.make_suffix fname ".v" in
- 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
- try while true do interp (snd (parse_sentence input)) done
- with End_of_input -> ()
-
-(* "locality" is the prefix "Local" attribute, while the "local" component
- * is the outdated/deprecated "Local" attribute of some vernacular commands
- * still parsed as the obsolete_locality grammar entry for retrocompatibility.
- * loc is the Loc.t of the vernacular command being interpreted. *)
-let interp ?proof ~loc locality poly c =
- prerr_endline (fun () -> "interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c));
- match c with
- (* Done later in this file *)
- | VernacLoad _ -> assert false
- | VernacFail _ -> assert false
- | VernacTime _ -> assert false
- | VernacRedirect _ -> assert false
- | VernacTimeout _ -> assert false
- | VernacStm _ -> assert false
-
- | VernacError e -> raise e
-
- (* Syntax *)
- | VernacSyntaxExtension (local,sl) ->
- vernac_syntax_extension locality local 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
- | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope locality qid scl
- | VernacInfix (local,mv,qid,sc) -> vernac_infix locality local mv qid sc
- | VernacNotation (local,c,infpl,sc) ->
- vernac_notation locality local c infpl sc
- | VernacNotationAddFormat(n,k,v) ->
- Metasyntax.add_notation_extra_printing_rule n k v
-
- (* Gallina *)
- | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d
- | VernacStartTheoremProof (k,l,top) -> vernac_start_proof locality poly k l top
- | VernacEndProof e -> vernac_end_proof ?proof e
- | VernacExactProof c -> vernac_exact_proof c
- | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl
- | VernacInductive (priv,finite,l) -> vernac_inductive poly priv finite l
- | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l
- | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l
- | VernacScheme l -> vernac_scheme l
- | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l
- | VernacUniverse l -> vernac_universe loc poly l
- | VernacConstraint l -> vernac_constraint loc poly l
-
- (* Modules *)
- | VernacDeclareModule (export,lid,bl,mtyo) ->
- vernac_declare_module export lid bl mtyo
- | VernacDefineModule (export,lid,bl,mtys,mexprl) ->
- vernac_define_module export lid bl mtys mexprl
- | VernacDeclareModuleType (lid,bl,mtys,mtyo) ->
- vernac_declare_module_type lid bl mtys mtyo
- | VernacInclude in_asts ->
- vernac_include in_asts
- (* Gallina extensions *)
- | VernacBeginSection lid -> vernac_begin_section lid
-
- | VernacEndSegment lid -> vernac_end_segment lid
-
- | VernacNameSectionHypSet (lid, set) -> vernac_name_sec_hyp lid set
-
- | VernacRequire (from, export, qidl) -> vernac_require from export qidl
- | VernacImport (export,qidl) -> vernac_import export qidl
- | VernacCanonical qid -> vernac_canonical qid
- | VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t
- | VernacIdentityCoercion (local,(_,id),s,t) ->
- vernac_identity_coercion locality poly local id s t
-
- (* Type classes *)
- | VernacInstance (abst, sup, inst, props, info) ->
- vernac_instance abst locality poly sup inst props info
- | VernacContext sup -> vernac_context poly sup
- | VernacDeclareInstances insts -> vernac_declare_instances locality insts
- | VernacDeclareClass id -> vernac_declare_class id
-
- (* Solving *)
- | VernacSolveExistential (n,c) -> vernac_solve_existential n c
-
- (* Auxiliary file and library management *)
- | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias
- | VernacRemoveLoadPath s -> vernac_remove_loadpath s
- | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s
- | VernacDeclareMLModule l -> vernac_declare_ml_module locality l
- | VernacChdir s -> vernac_chdir s
-
- (* State management *)
- | VernacWriteState s -> vernac_write_state s
- | VernacRestoreState s -> vernac_restore_state s
-
- (* Resetting *)
- | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm")
- | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm")
- | VernacBack _ -> anomaly (str "VernacBack not handled by Stm")
- | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm")
-
- (* Commands *)
- | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b
- | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids
- | VernacHints (local,dbnames,hints) ->
- vernac_hints locality poly local dbnames hints
- | VernacSyntacticDefinition (id,c,local,b) ->
- vernac_syntactic_definition locality id c local b
- | VernacDeclareImplicits (qid,l) ->
- vernac_declare_implicits locality qid l
- | VernacArguments (qid, args, more_implicits, nargs, flags) ->
- vernac_arguments locality qid args more_implicits nargs flags
- | VernacReserve bl -> vernac_reserve bl
- | VernacGeneralizable gen -> vernac_generalizable locality gen
- | VernacSetOpacity qidl -> vernac_set_opacity locality qidl
- | VernacSetStrategy l -> vernac_set_strategy locality l
- | VernacSetOption (key,v) -> vernac_set_option locality key v
- | VernacSetAppendOption (key,v) -> vernac_set_append_option locality key v
- | VernacUnsetOption key -> vernac_unset_option locality key
- | VernacRemoveOption (key,v) -> vernac_remove_option key v
- | VernacAddOption (key,v) -> vernac_add_option key v
- | VernacMemOption (key,v) -> vernac_mem_option key v
- | VernacPrintOption key -> vernac_print_option key
- | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c
- | VernacDeclareReduction (s,r) -> vernac_declare_reduction locality s r
- | VernacGlobalCheck c -> vernac_global_check c
- | VernacPrint p -> vernac_print p
- | VernacSearch (s,g,r) -> vernac_search 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")
-
- (* The STM should handle that, but LOAD bypasses the STM... *)
- | VernacAbort id -> CErrors.errorlabstrm "" (str "Abort cannot be used through the Load command")
- | VernacAbortAll -> CErrors.errorlabstrm "" (str "AbortAll cannot be used through the Load command")
- | VernacRestart -> CErrors.errorlabstrm "" (str "Restart cannot be used through the Load command")
- | VernacUndo _ -> CErrors.errorlabstrm "" (str "Undo cannot be used through the Load command")
- | VernacUndoTo _ -> CErrors.errorlabstrm "" (str "UndoTo cannot be used through the Load command")
- | VernacBacktrack _ -> CErrors.errorlabstrm "" (str "Backtrack cannot be used through the Load command")
-
- (* Proof management *)
- | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false
- | VernacFocus n -> vernac_focus n
- | VernacUnfocus -> vernac_unfocus ()
- | VernacUnfocused -> vernac_unfocused ()
- | VernacBullet b -> vernac_bullet b
- | VernacSubproof n -> vernac_subproof n
- | 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
- | VernacProofMode mn -> Proof_global.set_proof_mode mn
- (* Toplevel control *)
- | VernacToplevelControl e -> raise e
-
- (* Extensions *)
- | VernacExtend (opn,args) -> Vernacinterp.call ?locality (opn,args)
-
- (* Handled elsewhere *)
- | VernacProgram _
- | VernacPolymorphic _
- | VernacLocal _ -> assert false
-
-(* Vernaculars that take a locality flag *)
-let check_vernac_supports_locality c l =
- match l, c with
- | None, _ -> ()
- | Some _, (
- VernacOpenCloseScope _
- | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _
- | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _
- | VernacAssumption _ | VernacStartTheoremProof _
- | VernacCoercion _ | VernacIdentityCoercion _
- | VernacInstance _ | VernacDeclareInstances _
- | VernacDeclareMLModule _
- | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _
- | VernacSyntacticDefinition _
- | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _
- | VernacGeneralizable _
- | VernacSetOpacity _ | VernacSetStrategy _
- | VernacSetOption _ | VernacSetAppendOption _ | VernacUnsetOption _
- | VernacDeclareReduction _
- | VernacExtend _
- | VernacInductive _) -> ()
- | Some _, _ -> CErrors.error "This command does not support Locality"
-
-(* Vernaculars that take a polymorphism flag *)
-let check_vernac_supports_polymorphism c p =
- match p, c with
- | None, _ -> ()
- | Some _, (
- VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _
- | VernacAssumption _ | VernacInductive _
- | VernacStartTheoremProof _
- | VernacCoercion _ | VernacIdentityCoercion _
- | VernacInstance _ | VernacDeclareInstances _
- | VernacHints _ | VernacContext _
- | VernacExtend _ | VernacUniverse _ | VernacConstraint _) -> ()
- | Some _, _ -> CErrors.error "This command does not support Polymorphism"
-
-let enforce_polymorphism = function
- | None -> Flags.is_universe_polymorphism ()
- | Some b -> Flags.make_polymorphic_flag b; b
-
-(** A global default timeout, controlled by option "Set Default Timeout n".
- Use "Unset Default Timeout" to deactivate it (or set it to 0). *)
-
-let default_timeout = ref None
-
-let _ =
- Goptions.declare_int_option
- { Goptions.optsync = true;
- Goptions.optdepr = false;
- Goptions.optname = "the default timeout";
- Goptions.optkey = ["Default";"Timeout"];
- Goptions.optread = (fun () -> !default_timeout);
- Goptions.optwrite = ((:=) default_timeout) }
-
-(** When interpreting a command, the current timeout is initially
- the default one, but may be modified locally by a Timeout command. *)
-
-let current_timeout = ref None
-
-let vernac_timeout f =
- match !current_timeout, !default_timeout with
- | Some n, _ | None, Some n ->
- let f () = f (); current_timeout := None in
- Control.timeout n f Timeout
- | None, None -> f ()
-
-let restore_timeout () = current_timeout := None
-
-let locate_if_not_already loc (e, info) =
- match Loc.get_loc info with
- | None -> (e, Loc.add_loc info loc)
- | Some l -> if Loc.is_ghost l then (e, Loc.add_loc info loc) else (e, info)
-
-exception HasNotFailed
-exception HasFailed of std_ppcmds
-
-let with_fail 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 ~with_header:false e))))
- ()
- with e when CErrors.noncritical e ->
- let (e, _) = CErrors.push e in
- match e with
- | HasNotFailed ->
- errorlabstrm "Fail" (str "The command has not failed!")
- | HasFailed msg ->
- if is_verbose () || !test_mode || !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 orig_program_mode = Flags.is_program_mode () in
- let rec aux ?locality ?polymorphism isprogcmd = function
- | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c
- | VernacProgram _ -> CErrors.error "Program mode specified twice"
- | VernacLocal (b, c) when Option.is_empty locality ->
- aux ~locality:b ?polymorphism isprogcmd c
- | VernacPolymorphic (b, c) when polymorphism = None ->
- aux ?locality ~polymorphism:b isprogcmd c
- | VernacPolymorphic (b, c) -> CErrors.error "Polymorphism specified twice"
- | VernacLocal _ -> CErrors.error "Locality specified twice"
- | VernacStm (Command c) -> aux ?locality ?polymorphism isprogcmd c
- | VernacStm (PGLast c) -> aux ?locality ?polymorphism isprogcmd c
- | VernacStm _ -> assert false (* Done by Stm *)
- | VernacFail v ->
- with_fail true (fun () -> aux ?locality ?polymorphism isprogcmd v)
- | VernacTimeout (n,v) ->
- current_timeout := Some n;
- aux ?locality ?polymorphism isprogcmd v
- | VernacRedirect (s, (_,v)) ->
- Feedback.with_output_to_file s (aux false) v
- | VernacTime (_,v) ->
- System.with_time !Flags.time
- (aux ?locality ?polymorphism isprogcmd) v;
- | VernacLoad (_,fname) -> vernac_load (aux false) fname
- | c ->
- check_vernac_supports_locality c locality;
- check_vernac_supports_polymorphism c polymorphism;
- let poly = enforce_polymorphism polymorphism in
- Obligations.set_program_mode isprogcmd;
- try
- vernac_timeout begin fun () ->
- if verbosely
- then Flags.verbosely (interp ?proof ~loc locality poly) c
- else Flags.silently (interp ?proof ~loc locality poly) c;
- if orig_program_mode || not !Flags.program_mode || isprogcmd then
- Flags.program_mode := orig_program_mode;
- ignore (Flags.use_polymorphic_flag ())
- end
- with
- | reraise when
- (match reraise with
- | Timeout -> true
- | e -> CErrors.noncritical e)
- ->
- let e = CErrors.push reraise in
- let e = locate_if_not_already loc e in
- let () = restore_timeout () in
- Flags.program_mode := orig_program_mode;
- ignore (Flags.use_polymorphic_flag ());
- iraise e
- in
- if verbosely then Flags.verbosely (aux false) c
- else aux false c
-
-let () = Hook.set Stm.interp_hook interp
-let () = Hook.set Stm.with_fail_hook with_fail
diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli
deleted file mode 100644
index 4e7fa4a0..00000000
--- a/toplevel/vernacentries.mli
+++ /dev/null
@@ -1,66 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Misctypes
-
-val dump_global : Libnames.reference or_by_notation -> unit
-
-(** Vernacular entries *)
-
-val show_prooftree : unit -> unit
-
-val show_node : unit -> unit
-
-val vernac_require :
- Libnames.reference option -> bool option -> Libnames.reference list -> unit
-
-(** This function can be used by any command that want to observe terms
- in the context of the current goal *)
-val get_current_context_of_args : int option -> Evd.evar_map * Environ.env
-
-(** The main interpretation function of vernacular expressions *)
-val interp :
- ?verbosely:bool ->
- ?proof:Proof_global.closed_proof ->
- Loc.t * Vernacexpr.vernac_expr -> unit
-
-(** Print subgoals when the verbose flag is on.
- Meant to be used inside vernac commands from plugins. *)
-
-val print_subgoals : unit -> unit
-val try_print_subgoals : unit -> unit
-
-(** The printing of goals via [print_subgoals] or during
- [interp] can be controlled by the following flag.
- Used for instance by coqide, since it has its own
- goal-fetching mechanism. *)
-
-val enable_goal_printing : bool ref
-
-(** Should Qed try to display the proof script ?
- True by default, but false in ProofGeneral and coqIDE *)
-
-val qed_display_script : bool ref
-
-(** Prepare a "match" template for a given inductive type.
- For each branch of the match, we list the constructor name
- followed by enough pattern variables.
- [Not_found] is raised if the given string isn't the qualid of
- a known inductive type. *)
-
-val make_cases : string -> string list list
-
-val vernac_end_proof :
- ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit
-
-val with_fail : bool -> (unit -> unit) -> unit
-
-val command_focus : unit Proof.focus_kind
-
-val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Tacexpr.raw_red_expr ->
- Evd.evar_map * Redexpr.red_expr) Hook.t
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
deleted file mode 100644
index d81e3d6b..00000000
--- a/toplevel/vernacinterp.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Util
-open Pp
-open CErrors
-
-type deprecation = bool
-type vernac_command = Genarg.raw_generic_argument list -> unit -> unit
-
-(* Table of vernac entries *)
-let vernac_tab =
- (Hashtbl.create 51 :
- (Vernacexpr.extend_name, deprecation * vernac_command) Hashtbl.t)
-
-let vinterp_add depr s f =
- try
- Hashtbl.add vernac_tab s (depr, f)
- with Failure _ ->
- errorlabstrm "vinterp_add"
- (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.")
-
-let overwriting_vinterp_add s f =
- begin
- try
- let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s
- with Not_found -> ()
- end;
- Hashtbl.add vernac_tab s (false, f)
-
-let vinterp_map s =
- try
- Hashtbl.find vernac_tab s
- with Failure _ | Not_found ->
- errorlabstrm "Vernac Interpreter"
- (str"Cannot find vernac command " ++ str (fst s) ++ str".")
-
-let vinterp_init () = Hashtbl.clear vernac_tab
-
-let warn_deprecated_command =
- let open CWarnings in
- create ~name:"deprecated-command" ~category:"deprecated"
- (fun pr -> str "Deprecated vernacular command: " ++ pr)
-
-(* Interpretation of a vernac command *)
-
-let call ?locality (opn,converted_args) =
- let loc = ref "Looking up command" in
- try
- let depr, callback = vinterp_map opn in
- let () = if depr then
- let rules = Egramml.get_extend_vernac_rule opn in
- let pr_gram = function
- | Egramml.GramTerminal s -> str s
- | Egramml.GramNonTerminal _ -> str "_"
- in
- let pr = pr_sequence pr_gram rules in
- warn_deprecated_command pr;
- in
- loc:= "Checking arguments";
- let hunk = callback converted_args in
- loc:= "Executing command";
- Locality.LocalityFixme.set locality;
- hunk();
- 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);
- iraise reraise
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
deleted file mode 100644
index 5149b541..00000000
--- a/toplevel/vernacinterp.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(** Interpretation of extended vernac phrases. *)
-
-type deprecation = bool
-type vernac_command = Genarg.raw_generic_argument list -> unit -> unit
-
-val vinterp_add : deprecation -> Vernacexpr.extend_name ->
- vernac_command -> unit
-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