diff options
Diffstat (limited to 'vernac')
90 files changed, 1729 insertions, 1505 deletions
diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 46f616c4ff..2bb4bac9a4 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/assumptions.mli b/vernac/assumptions.mli index 5e63829411..ba5076ec2a 100644 --- a/vernac/assumptions.mli +++ b/vernac/assumptions.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 7213ba4829..fb308fd316 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -163,6 +163,16 @@ let program = let locality = bool_attribute ~name:"Locality" ~on:"local" ~off:"global" +let option_locality = + let name = "Locality" in + attribute_of_list [ + ("local", single_key_parser ~name ~key:"local" Goptions.OptLocal); + ("global", single_key_parser ~name ~key:"global" Goptions.OptGlobal); + ("export", single_key_parser ~name ~key:"export" Goptions.OptExport); + ] >>= function + | None -> return Goptions.OptDefault + | Some l -> return l + let ukey = "universes" let universe_polymorphism_option_name = ["Universe"; "Polymorphism"] diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 7ecb7e4fb0..51bab79938 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -47,6 +47,7 @@ val polymorphic : bool attribute val program : bool attribute val template : bool option attribute val locality : bool option attribute +val option_locality : Goptions.option_locality attribute val deprecation : Deprecation.t option attribute val canonical_field : bool attribute val canonical_instance : bool attribute diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index bdf8511cce..0c9b9c7255 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -691,10 +691,10 @@ let make_bl_scheme mode mind = 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 = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let bl_goal = EConstr.of_constr bl_goal in - let (ans, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ctx bl_goal + let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, EConstr.EInstance.empty) lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -821,10 +821,10 @@ let make_lb_scheme mode mind = 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 = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let lb_goal = EConstr.of_constr lb_goal in - let (ans, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ctx lb_goal + let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -997,13 +997,13 @@ let make_eq_decidability mode mind = let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let u = Univ.Instance.empty in - let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) 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 ~poly:false ~side_eff (Global.env()) ctx - (EConstr.of_constr (compute_dec_goal (ind,u) lnamesparrec nparrec)) - (compute_dec_tact ind lnamesparrec nparrec) + let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx + ~typ:(EConstr.of_constr (compute_dec_goal (ind,u) lnamesparrec nparrec)) + (compute_dec_tact ind lnamesparrec nparrec) in ([|ans|], ctx), Evd.empty_side_effects diff --git a/vernac/auto_ind_decl.mli b/vernac/auto_ind_decl.mli index 0de8c61f59..dc2606c19f 100644 --- a/vernac/auto_ind_decl.mli +++ b/vernac/auto_ind_decl.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/canonical.ml b/vernac/canonical.ml index e41610b532..390ed62bee 100644 --- a/vernac/canonical.ml +++ b/vernac/canonical.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/canonical.mli b/vernac/canonical.mli index e4161b4f97..60dd4eb719 100644 --- a/vernac/canonical.mli +++ b/vernac/canonical.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/classes.ml b/vernac/classes.ml index 16b9e07fb2..6e929de581 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -29,7 +29,8 @@ module NamedDecl = Context.Named.Declaration (*i*) let set_typeclass_transparency c local b = - Hints.add_hints ~local [typeclasses_db] + let locality = if local then Goptions.OptLocal else Goptions.OptGlobal in + Hints.add_hints ~locality [typeclasses_db] (Hints.HintsTransparencyEntry (Hints.HintsReferences [c], b)) let classes_transparent_state () = @@ -38,12 +39,11 @@ let classes_transparent_state () = with Not_found -> TransparentState.empty let () = - Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; Hook.set Typeclasses.classes_transparent_state_hook classes_transparent_state -let add_instance_hint inst path local info poly = +let add_instance_hint inst path ~locality info poly = Flags.silently (fun () -> - Hints.add_hints ~local [typeclasses_db] + Hints.add_hints ~locality [typeclasses_db] (Hints.HintsResolveEntry [info, poly, false, Hints.PathHints path, inst])) () @@ -55,16 +55,16 @@ let is_local_for_hint i = add_instance_hint; don't ask hints to take discharge into account itself *) -let add_instance check inst = +let add_instance_base inst = let poly = Global.is_polymorphic inst.is_impl in - let local = is_local_for_hint inst in - add_instance_hint (Hints.IsGlobRef inst.is_impl) [inst.is_impl] local + let locality = if is_local_for_hint inst then Goptions.OptLocal else Goptions.OptGlobal in + add_instance_hint (Hints.IsGlobRef inst.is_impl) [inst.is_impl] ~locality inst.is_info poly; List.iter (fun (path, pri, c) -> let h = Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty) [@ocaml.warning "-3"] in add_instance_hint h path - local pri poly) - (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) + ~locality pri poly) + (build_subclasses ~check:(not (isVarRef inst.is_impl)) (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) let mk_instance cl info glob impl = @@ -104,7 +104,7 @@ let discharge_instance (_, inst) = let is_local i = (i.is_global == None) let rebuild_instance inst = - add_instance true inst; + add_instance_base inst; inst let classify_instance inst = @@ -124,7 +124,7 @@ let instance_input : instance -> obj = let add_instance i = Lib.add_anonymous_leaf (instance_input i); - add_instance true i + add_instance_base i let warning_not_a_class = let name = "not-a-class" in @@ -304,54 +304,52 @@ let id_of_class cl = mip.(0).Declarations.mind_typename | _ -> assert false -let instance_hook info global imps ?hook cst = - Impargs.maybe_declare_manual_implicits false cst imps; +let instance_hook info global ?hook cst = let info = intern_info info in let env = Global.env () in let sigma = Evd.from_env env in declare_instance env sigma (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant info global imps ?hook name decl poly sigma term termtype = +let declare_instance_constant info global impargs ?hook name udecl poly sigma term termtype = let kind = Decls.(IsDefinition Instance) in - let sigma, entry = DeclareDef.prepare_definition - ~allow_evars:false ~poly sigma decl ~types:(Some termtype) ~body:term in - let kn = Declare.declare_constant ~name ~kind (Declare.DefinitionEntry entry) in - Declare.definition_message name; - DeclareUniv.declare_univ_binders (GlobRef.ConstRef kn) (Evd.universe_binders sigma); - instance_hook info global imps ?hook (GlobRef.ConstRef kn) - -let do_declare_instance sigma ~global ~poly k u ctx ctx' pri decl imps subst name = + let scope = DeclareDef.Global Declare.ImportDefaultBehavior in + let kn = DeclareDef.declare_definition ~name ~kind ~scope ~impargs + ~opaque:false ~poly sigma ~udecl ~types:(Some termtype) ~body:term in + instance_hook info global ?hook kn + +let do_declare_instance sigma ~global ~poly k u ctx ctx' pri udecl impargs subst name = 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 termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let sigma, entry = DeclareDef.prepare_parameter ~allow_evars:false ~poly sigma decl termtype in + let sigma, entry = DeclareDef.prepare_parameter ~poly sigma ~udecl ~types:termtype in let cst = Declare.declare_constant ~name ~kind:Decls.(IsAssumption Logical) (Declare.ParameterEntry entry) in DeclareUniv.declare_univ_binders (GlobRef.ConstRef cst) (Evd.universe_binders sigma); - instance_hook pri global imps (GlobRef.ConstRef cst) + let cst = (GlobRef.ConstRef cst) in + Impargs.maybe_declare_manual_implicits false cst impargs; + instance_hook pri global cst -let declare_instance_program env sigma ~global ~poly name pri imps univdecl term termtype = +let declare_instance_program env sigma ~global ~poly name pri impargs udecl term termtype = let hook { DeclareDef.Hook.S.scope; dref; _ } = let cst = match dref with GlobRef.ConstRef kn -> kn | _ -> assert false in - Impargs.declare_manual_implicits false dref imps; let pri = intern_info pri in let env = Global.env () in let sigma = Evd.from_env env in declare_instance env sigma (Some pri) (not global) (GlobRef.ConstRef cst) in - let obls, _, term, typ = Obligations.eterm_obligations env name sigma 0 term termtype in + let obls, _, term, typ = RetrieveObl.retrieve_obligations env name sigma 0 term termtype in let hook = DeclareDef.Hook.make hook in - let ctx = Evd.evar_universe_context sigma in + let uctx = Evd.evar_universe_context sigma in let scope, kind = DeclareDef.Global Declare.ImportDefaultBehavior, Decls.Instance in let _ : DeclareObl.progress = - Obligations.add_definition ~name ~term ~univdecl ~scope ~poly ~kind ~hook typ ctx obls + Obligations.add_definition ~name ~term ~udecl ~scope ~poly ~kind ~hook ~impargs ~uctx typ obls in () -let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids term termtype = +let declare_instance_open sigma ?hook ~tac ~global ~poly id pri impargs udecl ids term termtype = (* 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 @@ -359,12 +357,12 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids t let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in let kind = Decls.(IsDefinition Instance) in - let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global imps ?hook dref)) in + let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global ?hook dref)) in let info = Lemmas.Info.make ~hook ~kind () in (* XXX: We need to normalize the type, otherwise Admitted / Qed will fails! This is due to a bug in proof_global :( *) let termtype = Evarutil.nf_evar sigma termtype in - let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info sigma termtype in + let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info ~impargs sigma termtype in (* spiwack: I don't know what to do with the status here. *) let lemma = match term with diff --git a/vernac/classes.mli b/vernac/classes.mli index 594df52c70..9698c14452 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/comArguments.ml b/vernac/comArguments.ml index 9d43debb77..90791a0906 100644 --- a/vernac/comArguments.ml +++ b/vernac/comArguments.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/comArguments.mli b/vernac/comArguments.mli index cbc5fc15e2..e48e883036 100644 --- a/vernac/comArguments.mli +++ b/vernac/comArguments.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 2e9f0283ca..47ae03e0a3 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -203,8 +203,12 @@ let context_insection sigma ~poly ctx = else Monomorphic_entry Univ.ContextSet.empty in let entry = Declare.definition_entry ~univs ~types:t b in - let _ : GlobRef.t = DeclareDef.declare_definition ~name ~scope:DeclareDef.Discharge - ~kind:Decls.(IsDefinition Definition) UnivNames.empty_binders entry [] + (* XXX Fixme: Use DeclareDef.prepare_definition *) + let uctx = Evd.evar_universe_context sigma in + let kind = Decls.(IsDefinition Definition) in + let _ : GlobRef.t = + DeclareDef.declare_entry ~name ~scope:DeclareDef.Discharge + ~kind ~impargs:[] ~uctx entry in () in diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index f5192fc696..4b953c8869 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/comCoercion.ml b/vernac/comCoercion.ml index 2c582da495..c339c53a9b 100644 --- a/vernac/comCoercion.ml +++ b/vernac/comCoercion.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/comCoercion.mli b/vernac/comCoercion.mli index f98ef4fdd6..3b44bdaf8a 100644 --- a/vernac/comCoercion.mli +++ b/vernac/comCoercion.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 5b3f15a08c..8a91e9e63f 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,6 @@ open Pp open Util open Redexpr open Constrintern -open Pretyping (* Commands of the interface: Constant definitions *) @@ -40,10 +39,50 @@ let check_imps ~impsty ~impsbody = | [], [] -> () in aux impsty impsbody +let protect_pattern_in_binder bl c ctypopt = + (* We turn "Definition d binders := body : typ" into *) + (* "Definition d := fun binders => body:type" *) + (* This is a hack while waiting for LocalPattern in regular environments *) + if List.exists (function Constrexpr.CLocalPattern _ -> true | _ -> false) bl + then + let t = match ctypopt with + | None -> CAst.make ?loc:c.CAst.loc (Constrexpr.CHole (None,Namegen.IntroAnonymous,None)) + | Some t -> t in + let loc = Loc.merge_opt c.CAst.loc t.CAst.loc in + let c = CAst.make ?loc @@ Constrexpr.CCast (c, Glob_term.CastConv t) in + let loc = match List.hd bl with + | Constrexpr.CLocalAssum (a::_,_,_) | Constrexpr.CLocalDef (a,_,_) -> a.CAst.loc + | Constrexpr.CLocalPattern {CAst.loc} -> loc + | Constrexpr.CLocalAssum ([],_,_) -> assert false in + let apply_under_binders f env evd c = + let rec aux env evd c = + let open Constr in + let open EConstr in + let open Context.Rel.Declaration in + match kind evd c with + | Lambda (x,t,c) -> + let evd,c = aux (push_rel (LocalAssum (x,t)) env) evd c in + evd, mkLambda (x,t,c) + | LetIn (x,b,t,c) -> + let evd,c = aux (push_rel (LocalDef (x,b,t)) env) evd c in + evd, mkLetIn (x,t,b,c) + | Case (ci,p,a,bl) -> + let evd,bl = Array.fold_left_map (aux env) evd bl in + evd, mkCase (ci,p,a,bl) + | Cast (c,_,_) -> f env evd c (* we remove the cast we had set *) + (* This last case may happen when reaching the proof of an + impossible case, as when pattern-matching on a vector of length 1 *) + | _ -> (evd,c) in + aux env evd c in + ([], Constrexpr_ops.mkLambdaCN ?loc:(Loc.merge_opt loc c.CAst.loc) bl c, None, apply_under_binders) + else + (bl, c, ctypopt, fun f env evd c -> f env evd c) + let interp_definition ~program_mode pl bl ~poly red_option c ctypopt = let env = Global.env() in (* Explicitly bound universes and constraints *) let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in + let (bl, c, ctypopt, apply_under_binders) = protect_pattern_in_binder bl c ctypopt in (* Build the parameters *) let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars ~program_mode env evd bl in (* Build the type *) @@ -63,46 +102,31 @@ let interp_definition ~program_mode pl bl ~poly red_option c ctypopt = evd, c, imps1@impsty, Some ty in (* Do the reduction *) - let evd, c = red_constant_body red_option env_bl evd c in + let evd, c = apply_under_binders (red_constant_body red_option) env_bl evd c in (* Declare the definition *) let c = EConstr.it_mkLambda_or_LetIn c ctx in let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in + (c, tyopt), evd, udecl, imps - let evd, ce = DeclareDef.prepare_definition ~allow_evars:program_mode - ~opaque:false ~poly evd udecl ~types:tyopt ~body:c in - - (ce, evd, udecl, imps) - -let check_definition ~program_mode (ce, evd, _, imps) = - let env = Global.env () in - check_evars_are_solved ~program_mode env evd; - ce +let do_definition ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = + let program_mode = false in + let (body, types), evd, udecl, impargs = + interp_definition ~program_mode udecl bl ~poly red_option c ctypopt + in + let kind = Decls.IsDefinition kind in + let _ : Names.GlobRef.t = + DeclareDef.declare_definition ~name ~scope ~kind ?hook ~impargs + ~opaque:false ~poly evd ~udecl ~types ~body + in () -let do_definition ~program_mode ?hook ~name ~scope ~poly ~kind univdecl bl red_option c ctypopt = - let (ce, evd, univdecl, imps as def) = - interp_definition ~program_mode univdecl bl ~poly red_option c ctypopt +let do_definition_program ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = + let program_mode = true in + let (body, types), evd, udecl, impargs = + interp_definition ~program_mode udecl bl ~poly red_option c ctypopt in - if program_mode then - let env = Global.env () in - let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in - assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); - assert(Univ.ContextSet.is_empty ctx); - Obligations.check_evars env evd; - let c = EConstr.of_constr c in - let typ = match ce.Declare.proof_entry_type with - | Some t -> EConstr.of_constr t - | None -> Retyping.get_type_of env evd c - in - let obls, _, c, cty = - Obligations.eterm_obligations env name evd 0 c typ - in - let ctx = Evd.evar_universe_context evd in - ignore(Obligations.add_definition - ~name ~term:c cty ctx ~univdecl ~implicits:imps ~scope ~poly ~kind ?hook obls) - else - let ce = check_definition ~program_mode def in - let uctx = Evd.evar_universe_context evd in - let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - let kind = Decls.IsDefinition kind in - ignore(DeclareDef.declare_definition ~name ~scope ~kind ?hook_data (Evd.universe_binders evd) ce imps) + let term, ty, uctx, obls = DeclareDef.prepare_obligation ~name ~poly ~body ~types ~udecl evd in + let _ : DeclareObl.progress = + Obligations.add_definition + ~name ~term ty ~uctx ~udecl ~impargs ~scope ~poly ~kind ?hook obls + in () diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 01505d0733..337da22018 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,8 +15,7 @@ open Constrexpr (** {6 Definitions/Let} *) val do_definition - : program_mode:bool - -> ?hook:DeclareDef.Hook.t + : ?hook:DeclareDef.Hook.t -> name:Id.t -> scope:DeclareDef.locality -> poly:bool @@ -28,18 +27,15 @@ val do_definition -> constr_expr option -> unit -(************************************************************************) -(** Internal API *) -(************************************************************************) - -(** Not used anywhere. *) -val interp_definition - : program_mode:bool +val do_definition_program + : ?hook:DeclareDef.Hook.t + -> name:Id.t + -> scope:DeclareDef.locality + -> poly:bool + -> kind:Decls.definition_object_kind -> universe_decl_expr option -> local_binder_expr list - -> poly:bool -> red_expr option -> constr_expr -> constr_expr option - -> Evd.side_effects Declare.proof_entry * - Evd.evar_map * UState.universe_decl * Impargs.manual_implicits + -> unit diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 65dffb3c0b..cbf0affc12 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,22 +9,9 @@ (************************************************************************) open Pp -open CErrors open Util -open Constr -open Context -open Vars -open Termops -open Declare open Names -open Constrexpr -open Constrexpr_ops open Constrintern -open Pretyping -open Evarutil -open Evarconv - -module RelDecl = Context.Rel.Declaration (* 3c| Fixpoints and co-fixpoints *) @@ -99,7 +86,7 @@ let check_mutuality env evd 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 evd id' def) names)) + (id, List.filter (fun id' -> not (Id.equal id id') && Termops.occur_var env evd id' def) names)) fixl in let po = partial_order Id.equal preorder in match List.filter (function (_,Inr _) -> true | _ -> false) po with @@ -110,13 +97,13 @@ let check_mutuality env evd isfix fixl = let interp_fix_context ~program_mode ~cofix env sigma fix = let before, after = if not cofix - then split_at_annot fix.Vernacexpr.binders fix.Vernacexpr.rec_order + then Constrexpr_ops.split_at_annot fix.Vernacexpr.binders fix.Vernacexpr.rec_order else [], fix.Vernacexpr.binders in let sigma, (impl_env, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma before in let sigma, (impl_env', ((env'', ctx'), imps')) = interp_context_evars ~program_mode ~impl_env ~shift:(Context.Rel.nhyps ctx) env' sigma after in - let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.Vernacexpr.rec_order in + let annot = Option.map (fun _ -> List.length (Termops.assums_of_rel_context ctx)) fix.Vernacexpr.rec_order in sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) let interp_fix_ccl ~program_mode sigma impls (env,_) fix = @@ -134,8 +121,8 @@ let interp_fix_body ~program_mode env_rec sigma impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx let prepare_recursive_declaration fixnames fixrs fixtypes fixdefs = - let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in - let names = List.map2 (fun id r -> make_annot (Name id) r) fixnames fixrs in + let defs = List.map (Vars.subst_vars (List.rev fixnames)) fixdefs in + let names = List.map2 (fun id r -> Context.make_annot (Name id) r) fixnames fixrs in (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) (* Jump over let-bindings. *) @@ -153,8 +140,8 @@ let compute_possible_guardness_evidences (ctx,_,recindex) = fixpoints ?) *) List.interval 0 (Context.Rel.nhyps ctx - 1) -type recursive_preentry = - Id.t list * Sorts.relevance list * constr option list * types list +type ('constr, 'types) recursive_preentry = + Id.t list * Sorts.relevance list * 'constr option list * 'types list (* Wellfounded definition *) @@ -177,9 +164,9 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis let open UState in let lsu = ls.univdecl_instance and usu = us.univdecl_instance in if not (CList.for_all2eq (fun x y -> Id.equal x.CAst.v y.CAst.v) lsu usu) then - user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); + CErrors.user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); Some us) fixl None in - let sigma, decl = interp_univ_decl_opt env all_universes in + let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env all_universes in let sigma, (fixctxs, fiximppairs, fixannots) = on_snd List.split3 @@ List.fold_left_map (fun sigma -> interp_fix_context ~program_mode env sigma ~cofix) sigma fixl in @@ -188,7 +175,7 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis on_snd List.split3 @@ List.fold_left3_map (interp_fix_ccl ~program_mode) sigma fixctximpenvs fixctxs fixl in let fixtypes = List.map2 build_fix_type fixctxs fixccls in - let fixtypes = List.map (fun c -> nf_evar sigma c) fixtypes in + let fixtypes = List.map (fun c -> Evarutil.nf_evar sigma c) fixtypes in let fiximps = List.map3 (fun ctximps cclimps (_,ctx) -> ctximps@cclimps) fixctximps fixcclimps fixctxs in @@ -204,8 +191,8 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis Typing.solve_evars env sigma app with e when CErrors.noncritical e -> sigma, t in - sigma, LocalAssum (make_annot id Sorts.Relevant,fixprot) :: env' - else sigma, LocalAssum (make_annot id Sorts.Relevant,t) :: env') + sigma, LocalAssum (Context.make_annot id Sorts.Relevant,fixprot) :: env' + else sigma, LocalAssum (Context.make_annot id Sorts.Relevant,t) :: env') (sigma,[]) fixnames fixtypes in let env_rec = push_named_context rec_sign env in @@ -224,7 +211,7 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis () in (* Instantiate evars and check all are resolved *) - let sigma = solve_unif_constraints_with_heuristics env_rec sigma in + let sigma = Evarconv.solve_unif_constraints_with_heuristics env_rec sigma in let sigma = Evd.minimize_universes sigma in let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in @@ -238,85 +225,77 @@ let check_recursive isfix env evd (fixnames,_,fixdefs,_) = end let ground_fixpoint env evd (fixnames,fixrs,fixdefs,fixtypes) = - check_evars_are_solved ~program_mode:false env evd; + Pretyping.check_evars_are_solved ~program_mode:false env evd; let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr evd) c) fixdefs in let fixtypes = List.map EConstr.(to_constr evd) fixtypes in Evd.evar_universe_context evd, (fixnames,fixrs,fixdefs,fixtypes) -let interp_fixpoint ~cofix l = +(* XXX: Unify with interp_recursive *) +let interp_fixpoint ~cofix l : + ( (Constr.t, Constr.types) recursive_preentry * + UState.universe_decl * UState.t * + (EConstr.rel_context * Impargs.manual_implicits * int option) list) = let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l in check_recursive true env evd fix; let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) -let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs,fixdefs,fixtypes),udecl,ctx,fiximps) ntns = - let fix_kind, cofix, indexes = match indexes with - | Some indexes -> Decls.Fixpoint, false, indexes - | None -> Decls.CoFixpoint, true, [] +let build_recthms ~indexes fixnames fixtypes fiximps = + let fix_kind, cofix = match indexes with + | Some indexes -> Decls.Fixpoint, false + | None -> Decls.CoFixpoint, true in let thms = List.map3 (fun name typ (ctx,impargs,_) -> - { Lemmas.Recthm.name; typ - ; args = List.map RelDecl.get_name ctx; impargs}) - fixnames fixtypes fiximps in - let init_tac = - Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in + { DeclareDef.Recthm.name + ; typ + ; args = List.map Context.Rel.Declaration.get_name ctx + ; impargs}) + fixnames fixtypes fiximps + in + fix_kind, cofix, thms + +let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs,fixdefs,fixtypes),udecl,ctx,fiximps) ntns = + let fix_kind, cofix, thms = build_recthms ~indexes fixnames fixtypes fiximps in + let indexes = Option.default [] indexes in + let init_terms = Some fixdefs in let evd = Evd.from_ctx ctx in let lemma = Lemmas.start_lemma_with_initialization ~poly ~scope ~kind:(Decls.IsDefinition fix_kind) ~udecl - evd (Some(cofix,indexes,init_tac)) thms None in + evd (Some(cofix,indexes,init_terms)) thms None in (* Declare notations *) List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; lemma -let declare_fixpoint_generic ?indexes ~scope ~poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = - let indexes, cofix, fix_kind = - match indexes with - | Some indexes -> indexes, false, Decls.(IsDefinition Fixpoint) - | None -> [], true, Decls.(IsDefinition CoFixpoint) - in +let declare_fixpoint_generic ?indexes ~scope ~poly ((fixnames,fixrs,fixdefs,fixtypes),udecl,uctx,fiximps) ntns = (* We shortcut the proof process *) + let fix_kind, cofix, fixitems = build_recthms ~indexes fixnames fixtypes fiximps in let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in - let vars, fixdecls, gidx = - if not cofix then - let env = Global.env() in - let indexes = search_guard env indexes fixdecls in - let vars = Vars.universes_of_constr (mkFix ((indexes,0),fixdecls)) in - let fixdecls = List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in - vars, fixdecls, Some indexes - else (* cofix *) - let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in - let vars = Vars.universes_of_constr (List.hd fixdecls) in - vars, fixdecls, None - in - let fiximps = List.map (fun (n,r,p) -> r) fiximps in - let evd = Evd.from_ctx ctx in - let evd = Evd.restrict_universe_context evd vars in - let ctx = Evd.check_univ_decl ~poly evd pl in - let udecl = Evd.universe_binders evd in + let rec_declaration = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in + let fix_kind = Decls.IsDefinition fix_kind in let _ : GlobRef.t list = - List.map4 (fun name body types imps -> - let ce = Declare.definition_entry ~opaque:false ~types ~univs:ctx body in - DeclareDef.declare_definition ~name ~scope ~kind:fix_kind udecl ce imps) - fixnames fixdecls fixtypes fiximps + DeclareDef.declare_mutually_recursive ~scope ~opaque:false ~kind:fix_kind ~poly ~uctx + ~possible_indexes:indexes ~restrict_ucontext:true ~udecl ~ntns ~rec_declaration + fixitems in - recursive_message (not cofix) gidx fixnames; - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; () -let extract_decreasing_argument ~structonly = function { CAst.v = v } -> match v with +let extract_decreasing_argument ~structonly { CAst.v = v; _ } = + let open Constrexpr in + match v with | CStructRec na -> na | (CWfRec (na,_) | CMeasureRec (Some na,_,_)) when not structonly -> na | CMeasureRec (None,_,_) when not structonly -> - user_err Pp.(str "Decreasing argument must be specified in measure clause.") - | _ -> user_err Pp.(str - "Well-founded induction requires Program Fixpoint or Function.") + CErrors.user_err Pp.(str "Decreasing argument must be specified in measure clause.") + | _ -> + CErrors.user_err Pp.(str "Well-founded induction requires Program Fixpoint or Function.") (* This is a special case: if there's only one binder, we pick it as the recursive argument if none is provided. *) let adjust_rec_order ~structonly binders rec_order = - let rec_order = Option.map (fun rec_order -> match binders, rec_order with + let rec_order = Option.map (fun rec_order -> + let open Constrexpr in + match binders, rec_order with | [CLocalAssum([{ CAst.v = Name x }],_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) | [CLocalDef({ CAst.v = Name x },_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 4f8e9018de..a19b96f0f3 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Constr open Vernacexpr (** {6 Fixpoints and cofixpoints} *) @@ -40,6 +39,9 @@ val adjust_rec_order -> Constrexpr.recursion_order_expr option -> lident option +(** names / relevance / defs / types *) +type ('constr, 'types) recursive_preentry = Id.t list * Sorts.relevance list * 'constr option list * 'types list + (** Exported for Program *) val interp_recursive : (* Misc arguments *) @@ -49,18 +51,17 @@ val interp_recursive : (* env / signature / univs / evar_map *) (Environ.env * EConstr.named_context * UState.universe_decl * Evd.evar_map) * (* names / defs / types *) - (Id.t list * Sorts.relevance list * EConstr.constr option list * EConstr.types list) * + (EConstr.t, EConstr.types) recursive_preentry * (* ctx per mutual def / implicits / struct annotations *) (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Exported for Funind *) -type recursive_preentry = Id.t list * Sorts.relevance list * constr option list * types list - val interp_fixpoint : cofix:bool -> lident option fix_expr_gen list - -> recursive_preentry * UState.universe_decl * UState.t * + -> (Constr.t, Constr.types) recursive_preentry * + UState.universe_decl * UState.t * (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Very private function, do not use *) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 718e62b9b7..1f1700b4d6 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 1286e4a5c3..2b9da1d4e5 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/comPrimitive.ml b/vernac/comPrimitive.ml index b66ff876d3..bcfbc049fa 100644 --- a/vernac/comPrimitive.ml +++ b/vernac/comPrimitive.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/comPrimitive.mli b/vernac/comPrimitive.mli index c0db1cc464..588eb7fdea 100644 --- a/vernac/comPrimitive.mli +++ b/vernac/comPrimitive.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 84f8578ad4..56780d00a6 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -115,7 +115,7 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in Coqlib.check_required_library ["Coq";"Program";"Wf"]; let env = Global.env() in - let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in + let sigma, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in let sigma, (_, ((env', binders_rel), impls)) = interp_context_evars ~program_mode:true env sigma bl in let len = List.length binders_rel in let top_env = push_rel_context binders_rel env in @@ -234,7 +234,7 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let body = it_mkLambda_or_LetIn (mkApp (h_body, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let ty = EConstr.Unsafe.to_constr ty in - let univs = Evd.check_univ_decl ~poly sigma decl in + let univs = Evd.check_univ_decl ~poly sigma udecl in (*FIXME poly? *) let ce = definition_entry ~types:ty ~univs (EConstr.to_constr sigma body) in (* FIXME: include locality *) @@ -254,13 +254,13 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = in (* XXX: Capturing sigma here... bad bad *) let hook = DeclareDef.Hook.make (hook sigma) in - Obligations.check_evars env sigma; + RetrieveObl.check_evars env sigma; let evars, _, evars_def, evars_typ = - Obligations.eterm_obligations env recname sigma 0 def typ + RetrieveObl.retrieve_obligations env recname sigma 0 def typ in - let ctx = Evd.evar_universe_context sigma in - ignore(Obligations.add_definition ~name:recname ~term:evars_def ~univdecl:decl - ~poly evars_typ ctx evars ~hook) + let uctx = Evd.evar_universe_context sigma in + ignore(Obligations.add_definition ~name:recname ~term:evars_def ~udecl + ~poly evars_typ ~uctx evars ~hook) let out_def = function | Some def -> def @@ -273,7 +273,7 @@ let collect_evars_of_term evd c ty = let do_program_recursive ~scope ~poly fixkind fixl = let cofix = fixkind = DeclareObl.IsCoFixpoint in - let (env, rec_sign, pl, evd), fix, info = + let (env, rec_sign, udecl, evd), fix, info = interp_recursive ~cofix ~program_mode:true fixl in (* Program-specific code *) @@ -281,15 +281,15 @@ let do_program_recursive ~scope ~poly fixkind fixl = 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 = + let collect_evars name def typ impargs = (* Generalize by the recursive prototypes *) let def = nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) in let 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 + RetrieveObl.retrieve_obligations env name evm (List.length rec_sign) def typ in - (id, def, typ, imps, evars) + ({ DeclareDef.Recthm.name; typ; impargs; args = [] }, def, evars) in let (fixnames,fixrs,fixdefs,fixtypes) = fix in let fiximps = List.map pi2 info in @@ -311,13 +311,13 @@ let do_program_recursive ~scope ~poly fixkind fixl = ((indexes,i),fixdecls)) fixl end in - let ctx = Evd.evar_universe_context evd in + let uctx = Evd.evar_universe_context evd in let kind = match fixkind with | DeclareObl.IsFixpoint _ -> Decls.Fixpoint | DeclareObl.IsCoFixpoint -> Decls.CoFixpoint in let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in - Obligations.add_mutual_definitions defs ~poly ~scope ~kind ~univdecl:pl ctx ntns fixkind + Obligations.add_mutual_definitions defs ~poly ~scope ~kind ~udecl ~uctx ntns fixkind let do_fixpoint ~scope ~poly l = let g = List.map (fun { Vernacexpr.rec_order } -> rec_order) l in diff --git a/vernac/comProgramFixpoint.mli b/vernac/comProgramFixpoint.mli index a851e4dff5..6851c9f69e 100644 --- a/vernac/comProgramFixpoint.mli +++ b/vernac/comProgramFixpoint.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 39fd332184..1607771598 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,7 +9,6 @@ (************************************************************************) open Declare -open Impargs type locality = Discharge | Global of Declare.import_status @@ -34,47 +33,97 @@ module Hook = struct let make hook = CEphemeron.create hook - let call ?hook ?fix_exn x = - try Option.iter (fun hook -> CEphemeron.get hook x) hook - with e when CErrors.noncritical e -> - let e = Exninfo.capture e in - let e = Option.cata (fun fix -> fix e) e fix_exn in - Exninfo.iraise e + let call ?hook x = Option.iter (fun hook -> CEphemeron.get hook x) hook + end (* Locality stuff *) -let declare_definition ~name ~scope ~kind ?hook_data udecl ce imps = - let fix_exn = Declare.Internal.get_fix_exn ce in - let should_suggest = ce.Declare.proof_entry_opaque && - Option.is_empty ce.Declare.proof_entry_secctx in +let declare_entry ~name ~scope ~kind ?hook ?(obls=[]) ~impargs ~uctx entry = + let should_suggest = entry.Declare.proof_entry_opaque && + Option.is_empty entry.Declare.proof_entry_secctx in + let ubind = UState.universe_binders uctx in let dref = match scope with | Discharge -> - let () = declare_variable ~name ~kind (SectionLocalDef ce) in + let () = declare_variable ~name ~kind (SectionLocalDef entry) in if should_suggest then Proof_using.suggest_variable (Global.env ()) name; Names.GlobRef.VarRef name | Global local -> - let kn = declare_constant ~name ~local ~kind (DefinitionEntry ce) in + let kn = declare_constant ~name ~local ~kind (DefinitionEntry entry) in let gr = Names.GlobRef.ConstRef kn in if should_suggest then Proof_using.suggest_constant (Global.env ()) kn; - let () = DeclareUniv.declare_univ_binders gr udecl in + let () = DeclareUniv.declare_univ_binders gr ubind in gr in - let () = maybe_declare_manual_implicits false dref imps in + let () = Impargs.maybe_declare_manual_implicits false dref impargs in let () = definition_message name in - begin - match hook_data with - | None -> () - | Some (hook, uctx, obls) -> - Hook.call ~fix_exn ~hook { Hook.S.uctx; obls; scope; dref } - end; + Option.iter (fun hook -> Hook.call ~hook { Hook.S.uctx; obls; scope; dref }) hook; dref +let declare_entry ~name ~scope ~kind ?hook ?obls ~impargs ~uctx entry = + try declare_entry ~name ~scope ~kind ?hook ?obls ~impargs ~uctx entry + with exn -> + let exn = Exninfo.capture exn in + let fix_exn = Declare.Internal.get_fix_exn entry in + Exninfo.iraise (fix_exn exn) + +let mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes = + match possible_indexes with + | Some possible_indexes -> + let env = Global.env() in + let indexes = Pretyping.search_guard env possible_indexes rec_declaration in + let vars = Vars.universes_of_constr (Constr.mkFix ((indexes,0),rec_declaration)) in + let fixdecls = CList.map_i (fun i _ -> Constr.mkFix ((indexes,i),rec_declaration)) 0 fixitems in + vars, fixdecls, Some indexes + | None -> + let fixdecls = CList.map_i (fun i _ -> Constr.mkCoFix (i,rec_declaration)) 0 fixitems in + let vars = Vars.universes_of_constr (List.hd fixdecls) in + vars, fixdecls, None + +module Recthm = struct + type t = + { name : Names.Id.t + (** Name of theorem *) + ; typ : Constr.t + (** Type of theorem *) + ; args : Names.Name.t list + (** Names to pre-introduce *) + ; impargs : Impargs.manual_implicits + (** Explicitily declared implicit arguments *) + } +end + +let declare_mutually_recursive ~opaque ~scope ~kind ~poly ~uctx ~udecl ~ntns ~rec_declaration ~possible_indexes ?(restrict_ucontext=true) fixitems = + let vars, fixdecls, indexes = + mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes in + let uctx, univs = + (* XXX: Obligations don't do this, this seems like a bug? *) + if restrict_ucontext + then + let uctx = UState.restrict uctx vars in + let univs = UState.check_univ_decl ~poly uctx udecl in + uctx, univs + else + let univs = UState.univ_entry ~poly uctx in + uctx, univs + in + let csts = CList.map2 + (fun Recthm.{ name; typ; impargs } body -> + let entry = Declare.definition_entry ~opaque ~types:typ ~univs body in + declare_entry ~name ~scope ~kind ~impargs ~uctx entry) + fixitems fixdecls + in + let isfix = Option.is_empty possible_indexes in + let fixnames = List.map (fun { Recthm.name } -> name) fixitems in + Declare.recursive_message isfix indexes fixnames; + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; + csts + let warn_let_as_axiom = CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" Pp.(fun id -> strbrk "Let definition" ++ spc () ++ Names.Id.print id ++ spc () ++ strbrk "declared as an axiom.") -let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = +let declare_assumption ~name ~scope ~hook ~impargs ~uctx pe = let local = match scope with | Discharge -> warn_let_as_axiom name; Declare.ImportNeedQualified | Global local -> local @@ -86,27 +135,59 @@ let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = let () = Impargs.maybe_declare_manual_implicits false dref impargs in let () = Declare.assumption_message name in let () = DeclareUniv.declare_univ_binders dref (UState.universe_binders uctx) in - let () = Hook.(call ?fix_exn ?hook { S.uctx; obls = []; scope; dref}) in + let () = Hook.(call ?hook { S.uctx; obls = []; scope; dref}) in dref +let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = + try declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + with exn -> + let exn = Exninfo.capture exn in + let exn = Option.cata (fun fix -> fix exn) exn fix_exn in + Exninfo.iraise exn + (* Preparing proof entries *) -let check_definition_evars ~allow_evars sigma = +let prepare_definition ?opaque ?inline ?fix_exn ~poly ~udecl ~types ~body sigma = let env = Global.env () in - if not allow_evars then Pretyping.check_evars_are_solved ~program_mode:false env sigma + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:true + sigma (fun nf -> nf body, Option.map nf types) + in + let univs = Evd.check_univ_decl ~poly sigma udecl in + let entry = definition_entry ?fix_exn ?opaque ?inline ?types ~univs body in + let uctx = Evd.evar_universe_context sigma in + entry, uctx -let prepare_definition ~allow_evars ?opaque ?inline ~poly sigma udecl ~types ~body = - check_definition_evars ~allow_evars sigma; - let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:(not allow_evars) +let declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ?hook + ?obls ~poly ?inline ~types ~body ?fix_exn sigma = + let entry, uctx = prepare_definition ?fix_exn ~opaque ~poly ~udecl ~types ~body ?inline sigma in + declare_entry ~name ~scope ~kind ~impargs ?obls ?hook ~uctx entry + +let prepare_obligation ?opaque ?inline ~name ~poly ~udecl ~types ~body sigma = + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:false sigma (fun nf -> nf body, Option.map nf types) in let univs = Evd.check_univ_decl ~poly sigma udecl in - sigma, definition_entry ?opaque ?inline ?types ~univs body + let ce = definition_entry ?opaque ?inline ?types ~univs body in + let env = Global.env () in + let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in + assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); + assert(Univ.ContextSet.is_empty ctx); + RetrieveObl.check_evars env sigma; + let c = EConstr.of_constr c in + let typ = match ce.Declare.proof_entry_type with + | Some t -> EConstr.of_constr t + | None -> Retyping.get_type_of env sigma c + in + let obls, _, c, cty = RetrieveObl.retrieve_obligations env name sigma 0 c typ in + let uctx = Evd.evar_universe_context sigma in + c, cty, uctx, obls -let prepare_parameter ~allow_evars ~poly sigma udecl typ = - check_definition_evars ~allow_evars sigma; - let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:(not allow_evars) - sigma (fun nf -> nf typ) +let prepare_parameter ~poly ~udecl ~types sigma = + let env = Global.env () in + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:true + sigma (fun nf -> nf types) in let univs = Evd.check_univ_decl ~poly sigma udecl in sigma, (None(*proof using*), (typ, univs), None(*inline*)) diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index c668ab2ac4..3bc1e25f19 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -36,17 +36,42 @@ module Hook : sig end val make : (S.t -> unit) -> t - val call : ?hook:t -> ?fix_exn:Future.fix_exn -> S.t -> unit + val call : ?hook:t -> S.t -> unit end -val declare_definition +(** Declare an interactively-defined constant *) +val declare_entry : name:Id.t -> scope:locality -> kind:Decls.logical_kind - -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) - -> UnivNames.universe_binders + -> ?hook:Hook.t + -> ?obls:(Id.t * Constr.t) list + -> impargs:Impargs.manual_implicits + -> uctx:UState.t -> Evd.side_effects Declare.proof_entry - -> Impargs.manual_implicits + -> GlobRef.t + +(** Declares a non-interactive constant; [body] and [types] will be + normalized w.r.t. the passed [evar_map] [sigma]. Universes should + be handled properly, including minimization and restriction. Note + that [sigma] is checked for unresolved evars, thus you should be + careful not to submit open terms or evar maps with stale, + unresolved existentials *) +val declare_definition + : name:Id.t + -> scope:locality + -> kind:Decls.logical_kind + -> opaque:bool + -> impargs:Impargs.manual_implicits + -> udecl:UState.universe_decl + -> ?hook:Hook.t + -> ?obls:(Id.t * Constr.t) list + -> poly:bool + -> ?inline:bool + -> types:EConstr.t option + -> body:EConstr.t + -> ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) + -> Evd.evar_map -> GlobRef.t val declare_assumption @@ -59,17 +84,49 @@ val declare_assumption -> Entries.parameter_entry -> GlobRef.t -val prepare_definition - : allow_evars:bool - -> ?opaque:bool +module Recthm : sig + type t = + { name : Id.t + (** Name of theorem *) + ; typ : Constr.t + (** Type of theorem *) + ; args : Name.t list + (** Names to pre-introduce *) + ; impargs : Impargs.manual_implicits + (** Explicitily declared implicit arguments *) + } +end + +val declare_mutually_recursive + : opaque:bool + -> scope:locality + -> kind:Decls.logical_kind + -> poly:bool + -> uctx:UState.t + -> udecl:UState.universe_decl + -> ntns:Vernacexpr.decl_notation list + -> rec_declaration:Constr.rec_declaration + -> possible_indexes:int list list option + -> ?restrict_ucontext:bool + (** XXX: restrict_ucontext should be always true, this seems like a + bug in obligations, so this parameter should go away *) + -> Recthm.t list + -> Names.GlobRef.t list + +val prepare_obligation + : ?opaque:bool -> ?inline:bool + -> name:Id.t -> poly:bool - -> Evd.evar_map - -> UState.universe_decl + -> udecl:UState.universe_decl -> types:EConstr.t option -> body:EConstr.t - -> Evd.evar_map * Evd.side_effects Declare.proof_entry + -> Evd.evar_map + -> Constr.constr * Constr.types * UState.t * RetrieveObl.obligation_info -val prepare_parameter : allow_evars:bool -> - poly:bool -> Evd.evar_map -> UState.universe_decl -> EConstr.types -> - Evd.evar_map * Entries.parameter_entry +val prepare_parameter + : poly:bool + -> udecl:UState.universe_decl + -> types:EConstr.types + -> Evd.evar_map + -> Evd.evar_map * Entries.parameter_entry diff --git a/vernac/declareInd.ml b/vernac/declareInd.ml index 7dd53564cc..2610f16d92 100644 --- a/vernac/declareInd.ml +++ b/vernac/declareInd.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/declareInd.mli b/vernac/declareInd.mli index 17647d50aa..ae649634a5 100644 --- a/vernac/declareInd.mli +++ b/vernac/declareInd.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index eb9b896ec6..bba3687256 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * 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) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,39 +18,96 @@ open Entries 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 : pconstant obligation_body option - ; obl_status : bool * Evar_kinds.obligation_definition_status - ; obl_deps : Int.Set.t - ; obl_tac : unit Proofview.tactic option } +module Obligation = struct + type t = + { obl_name : Id.t + ; obl_type : types + ; obl_location : Evar_kinds.t Loc.located + ; obl_body : pconstant 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 + let set_type ~typ obl = { obl with obl_type = typ } + let set_body ~body obl = { obl with obl_body = Some body } + +end + +type obligations = + { obls : Obligation.t array + ; remaining : int } type fixpoint_kind = | IsFixpoint of lident option list | IsCoFixpoint -type program_info = - { prg_name : Id.t - ; prg_body : constr - ; prg_type : constr - ; prg_ctx : UState.t - ; prg_univdecl : UState.universe_decl - ; prg_obligations : obligations - ; prg_deps : Id.t list - ; prg_fixkind : fixpoint_kind option - ; prg_implicits : Impargs.manual_implicits - ; prg_notations : Vernacexpr.decl_notation list - ; prg_poly : bool - ; prg_scope : DeclareDef.locality - ; prg_kind : Decls.definition_object_kind - ; prg_reduce : constr -> constr - ; prg_hook : DeclareDef.Hook.t option - ; prg_opaque : bool - } +module ProgramDecl = struct + + type t = + { prg_name : Id.t + ; prg_body : constr + ; prg_type : constr + ; prg_ctx : UState.t + ; prg_univdecl : UState.universe_decl + ; prg_obligations : obligations + ; prg_deps : Id.t list + ; prg_fixkind : fixpoint_kind option + ; prg_implicits : Impargs.manual_implicits + ; prg_notations : Vernacexpr.decl_notation list + ; prg_poly : bool + ; prg_scope : DeclareDef.locality + ; prg_kind : Decls.definition_object_kind + ; prg_reduce : constr -> constr + ; prg_hook : DeclareDef.Hook.t option + ; prg_opaque : bool + } + + open Obligation + + let make ?(opaque = false) ?hook n ~udecl ~uctx ~impargs + ~poly ~scope ~kind b t deps fixkind notations obls reduce = + 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.tag 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 + let ctx = UState.make_flexible_nonalgebraic uctx in + { prg_name = n + ; prg_body = b + ; prg_type = reduce t + ; prg_ctx = ctx + ; prg_univdecl = udecl + ; prg_obligations = { obls = obls' ; remaining = Array.length obls' } + ; prg_deps = deps + ; prg_fixkind = fixkind + ; prg_notations = notations + ; prg_implicits = impargs + ; prg_poly = poly + ; prg_scope = scope + ; prg_kind = kind + ; prg_reduce = reduce + ; prg_hook = hook + ; prg_opaque = opaque + } + + let set_uctx ~uctx prg = {prg with prg_ctx = uctx} +end + +open Obligation +open ProgramDecl (* Saving an obligation *) @@ -120,15 +177,16 @@ let shrink_body c ty = 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) - (***********************************************************************) (* Saving an obligation *) (***********************************************************************) +let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] + +let add_hint local prg cst = + let locality = if local then Goptions.OptLocal else Goptions.OptExport in + Hints.add_hints ~locality [Id.to_string prg.prg_name] (unfold_entry cst) + (* true = hide obligations *) let get_hide_obligations = Goptions.declare_bool_option_and_ref @@ -193,45 +251,24 @@ let get_prg_info_map () = !from_prg let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] -let close sec = +let check_can_close sec = if not (ProgMap.is_empty !from_prg) then let keys = map_keys !from_prg in CErrors.user_err ~hdr:"Program" Pp.( str "Unsolved obligations when closing " - ++ str sec ++ str ":" ++ spc () + ++ Id.print sec ++ str ":" ++ spc () ++ prlist_with_sep spc (fun x -> Id.print x) keys ++ ( str (if Int.equal (List.length keys) 1 then " has " else " have ") ++ str "unsolved obligations" )) -let input : program_info CEphemeron.key ProgMap.t -> Libobject.obj = - let open Libobject in - 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 ) } - -let map_replace k v m = - ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m) - -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 map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m) +let prgmap_op f = from_prg := f !from_prg +let progmap_remove prg = prgmap_op (ProgMap.remove prg.prg_name) +let progmap_add n prg = prgmap_op (ProgMap.add n prg) +let progmap_replace prg = prgmap_op (map_replace prg.prg_name prg) -let progmap_replace prg' = - Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg)) - -let obligations_solved prg = Int.equal (snd prg.prg_obligations) 0 +let obligations_solved prg = Int.equal prg.prg_obligations.remaining 0 let obligations_message rem = if rem > 0 then @@ -271,7 +308,7 @@ let rec intset_to = function | n -> Int.Set.add n (intset_to (pred n)) let obligation_substitution expand prg = - let obls, _ = prg.prg_obligations in + let obls = prg.prg_obligations.obls in let ints = intset_to (pred (Array.length obls)) in obl_substitution expand obls ints @@ -325,34 +362,21 @@ let get_fix_exn, stm_get_fix_exn = Hook.make () let declare_definition prg = let varsubst = obligation_substitution true prg in - let body, typ = subst_prog varsubst prg in - let nf = - UnivSubst.nf_evars_and_universes_opt_subst - (fun x -> None) - (UState.subst prg.prg_ctx) - in - let opaque = prg.prg_opaque in + let sigma = Evd.from_ctx prg.prg_ctx in + let body, types = subst_prog varsubst prg in + let body, types = EConstr.(of_constr body, Some (of_constr types)) in + (* All these should be grouped into a struct a some point *) + let opaque, poly, udecl, hook = prg.prg_opaque, prg.prg_poly, prg.prg_univdecl, prg.prg_hook in + let name, scope, kind, impargs = prg.prg_name, prg.prg_scope, Decls.(IsDefinition prg.prg_kind), prg.prg_implicits in let fix_exn = Hook.get get_fix_exn () in - let typ = nf typ in - let body = nf body in - let obls = List.map (fun (id, (_, c)) -> (id, nf c)) varsubst in - let uvars = - Univ.LSet.union - (Vars.universes_of_constr typ) - (Vars.universes_of_constr body) - in - let uctx = UState.restrict prg.prg_ctx uvars in - let univs = - UState.check_univ_decl ~poly:prg.prg_poly uctx prg.prg_univdecl - in - let ce = Declare.definition_entry ~fix_exn ~opaque ~types:typ ~univs body in + let obls = List.map (fun (id, (_, c)) -> (id, c)) varsubst in + (* XXX: This is doing normalization twice *) let () = progmap_remove prg in - let ubinders = UState.universe_binders uctx in - let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in - DeclareDef.declare_definition - ~name:prg.prg_name ~scope:prg.prg_scope ubinders - ~kind:Decls.(IsDefinition prg.prg_kind) ce - prg.prg_implicits ?hook_data + let kn = + DeclareDef.declare_definition ~name ~scope ~kind ~impargs ?hook ~obls + ~fix_exn ~opaque ~poly ~udecl ~types ~body sigma + in + kn let rec lam_index n t acc = match Constr.kind t with @@ -399,55 +423,42 @@ let declare_mutual_definition l = (xdef :: defs, xobls @ obls)) l ([], []) in (* let fixdefs = List.map reduce_fix fixdefs in *) - let fixdefs, fixrs,fixtypes, fiximps = List.split4 defs in + let fixdefs, fixrs, fixtypes, fixitems = + List.fold_right2 (fun (d,r,typ,impargs) name (a1,a2,a3,a4) -> + d :: a1, r :: a2, typ :: a3, + DeclareDef.Recthm.{ name; typ; impargs; args = [] } :: a4 + ) defs first.prg_deps ([],[],[],[]) + in let fixkind = Option.get first.prg_fixkind in let arrrec, recvec = (Array.of_list fixtypes, Array.of_list fixdefs) in let rvec = Array.of_list fixrs in let namevec = Array.of_list (List.map (fun x -> Name x.prg_name) l) in - let fixdecls = (Array.map2 make_annot namevec rvec, arrrec, recvec) in - let fixnames = first.prg_deps in - let opaque = first.prg_opaque in - let indexes, fixdecls = + let rec_declaration = (Array.map2 make_annot namevec rvec, arrrec, recvec) in + let possible_indexes = match fixkind with | IsFixpoint wfl -> - let possible_indexes = - List.map3 compute_possible_guardness_evidences wfl fixdefs fixtypes - in - let indexes = - Pretyping.search_guard (Global.env ()) possible_indexes fixdecls - in - ( Some indexes - , List.map_i (fun i _ -> mkFix ((indexes, i), fixdecls)) 0 l - ) - | IsCoFixpoint -> - (None, List.map_i (fun i _ -> mkCoFix (i, fixdecls)) 0 l) + Some (List.map3 compute_possible_guardness_evidences wfl fixdefs fixtypes) + | IsCoFixpoint -> None in + (* In the future we will pack all this in a proper record *) + let poly, scope, ntns, opaque = first.prg_poly, first.prg_scope, first.prg_notations, first.prg_opaque in + let kind = if fixkind != IsCoFixpoint then Decls.(IsDefinition Fixpoint) else Decls.(IsDefinition CoFixpoint) in (* Declare the recursive definitions *) - let poly = first.prg_poly in - let scope = first.prg_scope in - let univs = UState.univ_entry ~poly first.prg_ctx in - let fix_exn = Hook.get get_fix_exn () in - let kind = Decls.IsDefinition (if fixkind != IsCoFixpoint then Decls.Fixpoint else Decls.CoFixpoint) in - let udecl = UnivNames.empty_binders in + let udecl = UState.default_univ_decl in let kns = - List.map4 - (fun name body types imps -> - let ce = Declare.definition_entry ~opaque ~types ~univs body in - DeclareDef.declare_definition ~name ~scope ~kind udecl ce imps) - fixnames fixdecls fixtypes fiximps + DeclareDef.declare_mutually_recursive ~scope ~opaque ~kind + ~udecl ~ntns ~uctx:first.prg_ctx ~rec_declaration ~possible_indexes ~poly + ~restrict_ucontext:false fixitems in - (* Declare notations *) - List.iter - (Metasyntax.add_notation_interpretation (Global.env ())) - first.prg_notations; - Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; + (* Only for the first constant *) let dref = List.hd kns in - DeclareDef.Hook.(call ?hook:first.prg_hook ~fix_exn { S.uctx = first.prg_ctx; obls; scope; dref }); + DeclareDef.Hook.(call ?hook:first.prg_hook { S.uctx = first.prg_ctx; obls; scope; dref }); List.iter progmap_remove l; dref let update_obls prg obls rem = - let prg' = {prg with prg_obligations = (obls, rem)} in + let prg_obligations = { obls; remaining = rem } in + let prg' = {prg with prg_obligations} in progmap_replace prg'; obligations_message rem; if rem > 0 then Remain rem @@ -477,6 +488,17 @@ let dependencies obls n = obls; !res +let update_program_decl_on_defined prg obls num obl ~uctx rem ~auto = + let obls = Array.copy obls in + let () = obls.(num) <- obl in + let prg = { prg with prg_ctx = uctx } in + let () = ignore (update_obls prg obls (pred rem)) 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) deps None) + end + type obligation_qed_info = { name : Id.t ; num : int @@ -488,16 +510,12 @@ let obligation_terminator entries uctx { name; num; auto } = | [entry] -> let env = Global.env () in let ty = entry.Declare.proof_entry_type in - let body, uctx = Declare.inline_private_constants ~univs:uctx env entry in + let body, uctx = Declare.inline_private_constants ~uctx env entry in let sigma = Evd.from_ctx uctx in Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); (* Declare the obligation ourselves and drop the hook *) let prg = CEphemeron.get (ProgMap.find name !from_prg) in - (* Ensure universes are substituted properly in body and type *) - let body = EConstr.to_constr sigma (EConstr.of_constr body) in - let ty = Option.map (fun x -> EConstr.to_constr sigma (EConstr.of_constr x)) ty in - let ctx = Evd.evar_universe_context sigma in - let obls, rem = prg.prg_obligations in + let { obls; remaining=rem } = prg.prg_obligations in let obl = obls.(num) in let status = match obl.obl_status, entry.Declare.proof_entry_opaque with @@ -509,36 +527,57 @@ let obligation_terminator entries uctx { name; num; auto } = | (_, status), false -> status in let obl = { obl with obl_status = false, status } in - let ctx = - if prg.prg_poly then ctx - else UState.union prg.prg_ctx ctx + let uctx = + if prg.prg_poly then uctx + else UState.union prg.prg_ctx uctx in - let uctx = UState.univ_entry ~poly:prg.prg_poly ctx in - let (defined, obl) = declare_obligation prg obl body ty uctx in - let obls = Array.copy obls in - let () = obls.(num) <- obl in + let univs = UState.univ_entry ~poly:prg.prg_poly uctx in + let (defined, obl) = declare_obligation prg obl body ty univs in let prg_ctx = if prg.prg_poly then (* Polymorphic *) (* We merge the new universes and constraints of the polymorphic obligation with the existing ones *) - UState.union prg.prg_ctx ctx + UState.union prg.prg_ctx uctx else (* The first obligation, if defined, declares the univs of the constant, each subsequent obligation declares its own additional universes and constraints if any *) if defined then UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) - else ctx + else uctx in - let prg = {prg with prg_ctx} in - ignore (update_obls prg obls (pred rem)); - if pred rem > 0 then - let deps = dependencies obls num in - if not (Int.Set.is_empty deps) then - ignore (auto (Some name) deps None) + update_program_decl_on_defined prg obls num obl ~uctx:prg_ctx rem ~auto | _ -> CErrors.anomaly Pp.( str "[obligation_terminator] close_proof returned more than one proof \ term") + +(* Similar to the terminator but for interactive paths, as the + terminator is only called in interactive proof mode *) +let obligation_hook prg obl num auto { DeclareDef.Hook.S.uctx = ctx'; dref; _ } = + let { obls; remaining=rem } = prg.prg_obligations in + let cst = match dref with GlobRef.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 inst, ctx' = + if not prg.prg_poly (* Not polymorphic *) then + (* The universe context was declared globally, we continue + from the new global environment. *) + let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let ctx' = UState.merge_subst ctx (UState.subst ctx') in + Univ.Instance.empty, ctx' + else + (* We get the right order somehow, but surely it could be enforced in a clearer way. *) + let uctx = UState.context ctx' in + Univ.UContext.instance uctx, ctx' + in + let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in + let () = if transparent then add_hint true prg cst in + update_program_decl_on_defined prg obls num obl ~uctx:ctx' rem ~auto diff --git a/vernac/declareObl.mli b/vernac/declareObl.mli index 7d8a112cc6..16c0413caf 100644 --- a/vernac/declareObl.mli +++ b/vernac/declareObl.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * 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) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,61 +13,101 @@ open Constr 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 : pconstant obligation_body option - ; obl_status : bool * Evar_kinds.obligation_definition_status - ; obl_deps : Int.Set.t - ; obl_tac : unit Proofview.tactic option } +module Obligation : sig -type obligations = obligation array * int + type t = private + { obl_name : Id.t + ; obl_type : types + ; obl_location : Evar_kinds.t Loc.located + ; obl_body : pconstant obligation_body option + ; obl_status : bool * Evar_kinds.obligation_definition_status + ; obl_deps : Int.Set.t + ; obl_tac : unit Proofview.tactic option } + + val set_type : typ:Constr.types -> t -> t + val set_body : body:pconstant obligation_body -> t -> t + +end + +type obligations = + { obls : Obligation.t array + ; remaining : int } type fixpoint_kind = | IsFixpoint of lident option list | IsCoFixpoint -type program_info = - { prg_name : Id.t - ; prg_body : constr - ; prg_type : constr - ; prg_ctx : UState.t - ; prg_univdecl : UState.universe_decl - ; prg_obligations : obligations - ; prg_deps : Id.t list - ; prg_fixkind : fixpoint_kind option - ; prg_implicits : Impargs.manual_implicits - ; prg_notations : Vernacexpr.decl_notation list - ; prg_poly : bool - ; prg_scope : DeclareDef.locality - ; prg_kind : Decls.definition_object_kind - ; prg_reduce : constr -> constr - ; prg_hook : DeclareDef.Hook.t option - ; prg_opaque : bool - } +(* Information about a single [Program {Definition,Lemma,..}] declaration *) +module ProgramDecl : sig + + type t = private + { prg_name : Id.t + ; prg_body : constr + ; prg_type : constr + ; prg_ctx : UState.t + ; prg_univdecl : UState.universe_decl + ; prg_obligations : obligations + ; prg_deps : Id.t list + ; prg_fixkind : fixpoint_kind option + ; prg_implicits : Impargs.manual_implicits + ; prg_notations : Vernacexpr.decl_notation list + ; prg_poly : bool + ; prg_scope : DeclareDef.locality + ; prg_kind : Decls.definition_object_kind + ; prg_reduce : constr -> constr + ; prg_hook : DeclareDef.Hook.t option + ; prg_opaque : bool + } + + val make : + ?opaque:bool + -> ?hook:DeclareDef.Hook.t + -> Names.Id.t + -> udecl:UState.universe_decl + -> uctx:UState.t + -> impargs:Impargs.manual_implicits + -> poly:bool + -> scope:DeclareDef.locality + -> kind:Decls.definition_object_kind + -> Constr.constr option + -> Constr.types + -> Names.Id.t list + -> fixpoint_kind option + -> Vernacexpr.decl_notation list + -> ( Names.Id.t + * Constr.types + * Evar_kinds.t Loc.located + * (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t + * unit Proofview.tactic option ) + array + -> (Constr.constr -> Constr.constr) + -> t + + val set_uctx : uctx:UState.t -> t -> t +end val declare_obligation : - program_info - -> obligation + ProgramDecl.t + -> Obligation.t -> Constr.types -> Constr.types option -> Entries.universes_entry - -> bool * obligation + -> bool * Obligation.t (** [declare_obligation] Save an obligation *) module ProgMap : CMap.ExtS with type key = Id.t and module Set := Id.Set -val declare_definition : program_info -> Names.GlobRef.t +val declare_definition : ProgramDecl.t -> Names.GlobRef.t +(** Resolution status of a program *) type progress = - (* Resolution status of a program *) | Remain of int - (* n obligations remaining *) + (** n obligations remaining *) | Dependent - (* Dependent on other definitions *) + (** Dependent on other definitions *) | Defined of GlobRef.t - (* Defined as id *) + (** Defined as id *) type obligation_qed_info = { name : Id.t @@ -79,32 +119,44 @@ val obligation_terminator : Evd.side_effects Declare.proof_entry list -> UState.t -> obligation_qed_info -> unit -(** [obligation_terminator] part 2 of saving an obligation *) +(** [obligation_terminator] part 2 of saving an obligation, proof mode *) + +val obligation_hook + : ProgramDecl.t + -> Obligation.t + -> Int.t + -> (Names.Id.t option -> Int.Set.t -> 'a option -> 'b) + -> DeclareDef.Hook.S.t + -> unit +(** [obligation_hook] part 2 of saving an obligation, non-interactive mode *) val update_obls : - program_info - -> obligation array + ProgramDecl.t + -> Obligation.t array -> int -> progress (** [update_obls prg obls n progress] What does this do? *) (** { 2 Util } *) -val get_prg_info_map : unit -> program_info CEphemeron.key ProgMap.t +(** Check obligations are properly solved before closing a section *) +val check_can_close : Id.t -> unit + +val get_prg_info_map : unit -> ProgramDecl.t CEphemeron.key ProgMap.t val program_tcc_summary_tag : - program_info CEphemeron.key Id.Map.t Summary.Dyn.tag + ProgramDecl.t CEphemeron.key Id.Map.t Summary.Dyn.tag val obl_substitution : bool - -> obligation array + -> Obligation.t array -> Int.Set.t -> (ProgMap.key * (Constr.types * Constr.types)) list -val dependencies : obligation array -> int -> Int.Set.t +val dependencies : Obligation.t array -> int -> Int.Set.t val err_not_transp : unit -> unit -val progmap_add : ProgMap.key -> program_info CEphemeron.key -> unit +val progmap_add : ProgMap.key -> ProgramDecl.t CEphemeron.key -> unit (* This is a hack to make it possible for Obligations to craft a Qed * behind the scenes. The fix_exn the Stm attaches to the Future proof diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml index def2fdad2a..300dfe6c35 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/declareUniv.mli b/vernac/declareUniv.mli index ce2a6e225c..51f3f5e0fb 100644 --- a/vernac/declareUniv.mli +++ b/vernac/declareUniv.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index e645fc552b..4f527b73d0 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/declaremods.mli b/vernac/declaremods.mli index 23f25bc597..e37299aad6 100644 --- a/vernac/declaremods.mli +++ b/vernac/declaremods.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index ead86bd12f..fdc8b1ba4c 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -325,51 +325,48 @@ let is_binder_level custom (custom',from) e = match e with | _ -> false let make_sep_rules = function - | [tk] -> Atoken tk + | [tk] -> + Pcoq.Symbol.token tk | tkl -> - let rec mkrule : 'a Tok.p list -> 'a rules = function - | [] -> Rules (Stop, fun _ -> (* dropped anyway: *) "") - | tkn :: rem -> - let Rules (r, f) = mkrule rem in - let r = NextNoRec (r, Atoken tkn) in - Rules (r, fun _ -> f) - in - let r = mkrule (List.rev tkl) in - Arules [r] + let r = Pcoq.mk_rule (List.rev tkl) in + Pcoq.Symbol.rules [r] type ('s, 'a) mayrec_symbol = -| MayRecNo : ('s, norec, 'a) symbol -> ('s, 'a) mayrec_symbol -| MayRecMay : ('s, mayrec, 'a) symbol -> ('s, 'a) mayrec_symbol +| MayRecNo : ('s, Gramlib.Grammar.norec, 'a) Symbol.t -> ('s, 'a) mayrec_symbol +| MayRecMay : ('s, Gramlib.Grammar.mayrec, 'a) Symbol.t -> ('s, 'a) mayrec_symbol let symbol_of_target : type s. _ -> _ -> _ -> _ -> s target -> (s, s) mayrec_symbol = fun custom p assoc from forpat -> - if is_binder_level custom from p then (* Prevent self *) MayRecNo (Aentryl (target_entry custom forpat, "200")) - else if is_self custom from p then MayRecMay Aself + if is_binder_level custom from p + then + (* Prevent self *) + MayRecNo (Pcoq.Symbol.nterml (target_entry custom forpat) "200") + else if is_self custom from p then MayRecMay Pcoq.Symbol.self else let g = target_entry custom forpat in let lev = adjust_level custom assoc from p in begin match lev with - | DefaultLevel -> MayRecNo (Aentry g) - | NextLevel -> MayRecMay Anext - | NumLevel lev -> MayRecNo (Aentryl (g, string_of_int lev)) + | DefaultLevel -> MayRecNo (Pcoq.Symbol.nterm g) + | NextLevel -> MayRecMay Pcoq.Symbol.next + | NumLevel lev -> MayRecNo (Pcoq.Symbol.nterml g (string_of_int lev)) end let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) mayrec_symbol = fun assoc from typ -> match typ with | TTConstr (s, p, forpat) -> symbol_of_target s p assoc from forpat | TTConstrList (s, typ', [], forpat) -> begin match symbol_of_target s typ' assoc from forpat with - | MayRecNo s -> MayRecNo (Alist1 s) - | MayRecMay s -> MayRecMay (Alist1 s) end + | MayRecNo s -> MayRecNo (Pcoq.Symbol.list1 s) + | MayRecMay s -> MayRecMay (Pcoq.Symbol.list1 s) end | TTConstrList (s, typ', tkl, forpat) -> begin match symbol_of_target s typ' assoc from forpat with - | MayRecNo s -> MayRecNo (Alist1sep (s, make_sep_rules tkl)) - | MayRecMay s -> MayRecMay (Alist1sep (s, make_sep_rules tkl)) end -| TTPattern p -> MayRecNo (Aentryl (Constr.pattern, string_of_int p)) -| TTClosedBinderList [] -> MayRecNo (Alist1 (Aentry Constr.binder)) -| TTClosedBinderList tkl -> MayRecNo (Alist1sep (Aentry Constr.binder, make_sep_rules tkl)) -| TTName -> MayRecNo (Aentry Prim.name) -| TTOpenBinderList -> MayRecNo (Aentry Constr.open_binders) -| TTBigint -> MayRecNo (Aentry Prim.bigint) -| TTReference -> MayRecNo (Aentry Constr.global) + | MayRecNo s -> MayRecNo (Pcoq.Symbol.list1sep s (make_sep_rules tkl) false) + | MayRecMay s -> MayRecMay (Pcoq.Symbol.list1sep s (make_sep_rules tkl) false) end +| TTPattern p -> MayRecNo (Pcoq.Symbol.nterml Constr.pattern (string_of_int p)) +| TTClosedBinderList [] -> MayRecNo (Pcoq.Symbol.list1 (Pcoq.Symbol.nterm Constr.binder)) +| TTClosedBinderList tkl -> MayRecNo (Pcoq.Symbol.list1sep (Pcoq.Symbol.nterm Constr.binder) (make_sep_rules tkl) false) +| TTName -> MayRecNo (Pcoq.Symbol.nterm Prim.name) +| TTOpenBinderList -> MayRecNo (Pcoq.Symbol.nterm Constr.open_binders) +| TTBigint -> MayRecNo (Pcoq.Symbol.nterm Prim.bignat) +| TTReference -> MayRecNo (Pcoq.Symbol.nterm Constr.global) let interp_entry forpat e = match e with | ETProdName -> TTAny TTName @@ -411,8 +408,8 @@ match e with | TTClosedBinderList _ -> { subst with binderlists = List.flatten v :: subst.binderlists } | TTBigint -> begin match forpat with - | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral (SPlus,NumTok.int v))) - | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral (SPlus,NumTok.int v))) + | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral (NumTok.Signed.of_int_string v))) + | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral (NumTok.Signed.of_int_string v))) end | TTReference -> begin match forpat with @@ -461,22 +458,22 @@ let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> s env -> ty_eval rem f { env with constrs; constrlists; } type ('s, 'a, 'r) mayrec_rule = -| MayRecRNo : ('s, Extend.norec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule -| MayRecRMay : ('s, Extend.mayrec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule +| MayRecRNo : ('s, Gramlib.Grammar.norec, 'a, 'r) Rule.t -> ('s, 'a, 'r) mayrec_rule +| MayRecRMay : ('s, Gramlib.Grammar.mayrec, 'a, 'r) Rule.t -> ('s, 'a, 'r) mayrec_rule let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) mayrec_rule = function -| TyStop -> MayRecRNo Stop +| TyStop -> MayRecRNo Rule.stop | TyMark (_, _, _, r) -> ty_erase r | TyNext (rem, TyTerm tok) -> begin match ty_erase rem with - | MayRecRNo rem -> MayRecRMay (Next (rem, Atoken tok)) - | MayRecRMay rem -> MayRecRMay (Next (rem, Atoken tok)) end + | MayRecRNo rem -> MayRecRMay (Rule.next rem (Symbol.token tok)) + | MayRecRMay rem -> MayRecRMay (Rule.next rem (Symbol.token tok)) end | TyNext (rem, TyNonTerm (_, _, s, _)) -> begin match ty_erase rem, s with - | MayRecRNo rem, MayRecNo s -> MayRecRMay (Next (rem, s)) - | MayRecRNo rem, MayRecMay s -> MayRecRMay (Next (rem, s)) - | MayRecRMay rem, MayRecNo s -> MayRecRMay (Next (rem, s)) - | MayRecRMay rem, MayRecMay s -> MayRecRMay (Next (rem, s)) end + | MayRecRNo rem, MayRecNo s -> MayRecRMay (Rule.next rem s) + | MayRecRNo rem, MayRecMay s -> MayRecRMay (Rule.next rem s) + | MayRecRMay rem, MayRecNo s -> MayRecRMay (Rule.next rem s) + | MayRecRMay rem, MayRecMay s -> MayRecRMay (Rule.next rem s) end type ('self, 'r) any_ty_rule = | AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule @@ -504,7 +501,7 @@ let target_to_bool : type r. r target -> bool = function | ForPattern -> true let prepare_empty_levels forpat (where,(pos,p4assoc,name,reinit)) = - let empty = (pos, [(name, p4assoc, [])]) in + let empty = { pos; data = [(name, p4assoc, [])] } in match reinit with | None -> ExtendRule (target_entry where forpat, empty) @@ -522,7 +519,13 @@ let rec pure_sublevels' assoc from forpat level = function let rem = pure_sublevels' assoc from forpat level rem in let push where p rem = match symbol_of_target where p assoc from forpat with - | MayRecNo (Aentryl (_,i)) when different_levels (fst from,level) (where,i) -> (where,int_of_string i) :: rem + | MayRecNo sym -> + (match Pcoq.level_of_nonterm sym with + | None -> rem + | Some i -> + if different_levels (fst from,level) (where,i) then + (where,int_of_string i) :: rem + else rem) | _ -> rem in (match e with | ETProdPattern i -> push InConstrEntry (NumLevel i,InternalProd) rem @@ -553,14 +556,15 @@ let extend_constr state forpat ng = let act = ty_eval r (make_act forpat ng.notgram_notation) empty in let rule = let r = match ty_erase r with - | MayRecRNo symbs -> Rule (symbs, act) - | MayRecRMay symbs -> Rule (symbs, act) in + | MayRecRNo symbs -> Pcoq.Production.make symbs act + | MayRecRMay symbs -> Pcoq.Production.make symbs act + in name, p4assoc, [r] in let r = match reinit with | None -> - ExtendRule (entry, (pos, [rule])) + ExtendRule (entry, { pos; data = [rule]}) | Some reinit -> - ExtendRuleReinit (entry, reinit, (pos, [rule])) + ExtendRuleReinit (entry, reinit, { pos; data = [rule]}) in (accu @ empty_rules @ [r], state) in diff --git a/vernac/egramcoq.mli b/vernac/egramcoq.mli index 6768d24d5c..9dc60b3b0c 100644 --- a/vernac/egramcoq.mli +++ b/vernac/egramcoq.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/egramml.ml b/vernac/egramml.ml index 2b1d99c7a9..bda1401bc9 100644 --- a/vernac/egramml.ml +++ b/vernac/egramml.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,14 +19,14 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - ('a raw_abstract_argument_type * ('s, _, 'a) symbol) Loc.located -> 's grammar_prod_item + ('a raw_abstract_argument_type * ('s, _, 'a) Symbol.t) Loc.located -> 's grammar_prod_item type 'a ty_arg = ('a -> raw_generic_argument) type ('self, 'tr, _, 'r) ty_rule = -| TyStop : ('self, Extend.norec, 'r, 'r) ty_rule -| TyNext : ('self, _, 'a, 'r) ty_rule * ('self, _, 'b) Extend.symbol * 'b ty_arg option -> - ('self, Extend.mayrec, 'b -> 'a, 'r) ty_rule +| TyStop : ('self, Gramlib.Grammar.norec, 'r, 'r) ty_rule +| TyNext : ('self, _, 'a, 'r) ty_rule * ('self, _, 'b) Symbol.t * 'b ty_arg option -> + ('self, Gramlib.Grammar.mayrec, 'b -> 'a, 'r) ty_rule type ('self, 'r) any_ty_rule = | AnyTyRule : ('self, _, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule @@ -35,7 +35,7 @@ let rec ty_rule_of_gram = function | [] -> AnyTyRule TyStop | GramTerminal s :: rem -> let AnyTyRule rem = ty_rule_of_gram rem in - let tok = Atoken (CLexer.terminal s) in + let tok = Pcoq.Symbol.token (CLexer.terminal s) in let r = TyNext (rem, tok, None) in AnyTyRule r | GramNonTerminal (_, (t, tok)) :: rem -> @@ -44,9 +44,9 @@ let rec ty_rule_of_gram = function let r = TyNext (rem, tok, inj) in AnyTyRule r -let rec ty_erase : type s tr a r. (s, tr, a, r) ty_rule -> (s, tr, a, r) Extend.rule = function -| TyStop -> Extend.Stop -| TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) +let rec ty_erase : type s tr a r. (s, tr, a, r) ty_rule -> (s, tr, a, r) Pcoq.Rule.t = function +| TyStop -> Pcoq.Rule.stop +| TyNext (rem, tok, _) -> Pcoq.Rule.next (ty_erase rem) tok type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r @@ -62,7 +62,7 @@ let make_rule f prod = let symb = ty_erase ty_rule in let f loc l = f loc (List.rev l) in let act = ty_eval ty_rule f in - Extend.Rule (symb, act) + Pcoq.Production.make symb act let rec proj_symbol : type a b c. (a, b, c) ty_user_symbol -> (a, b, c) genarg_type = function | TUentry a -> ExtraArg a @@ -90,4 +90,4 @@ let extend_vernac_command_grammar s nt gl = vernac_exts := (s,gl) :: !vernac_exts; let mkact loc l = VernacExtend (s, l) in let rules = [make_rule mkact gl] in - grammar_extend nt (None, [None, None, rules]) + grammar_extend nt { pos=None; data=[None, None, rules]} diff --git a/vernac/egramml.mli b/vernac/egramml.mli index 1fe2395df2..15f415ca3b 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,7 +18,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : ('a Genarg.raw_abstract_argument_type * - ('s, _, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item + ('s, _, 'a) Pcoq.Symbol.t) Loc.located -> 's grammar_prod_item val extend_vernac_command_grammar : extend_name -> vernac_expr Pcoq.Entry.t option -> @@ -32,4 +32,4 @@ val proj_symbol : ('a, 'b, 'c) Extend.ty_user_symbol -> ('a, 'b, 'c) Genarg.gena val make_rule : (Loc.t -> Genarg.raw_generic_argument list -> 'a) -> - 'a grammar_prod_item list -> 'a Extend.production_rule + 'a grammar_prod_item list -> 'a Pcoq.Production.t diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index 03dfc576a1..247f80181a 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index c1414c552a..a1cdc718d7 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -107,35 +107,40 @@ GRAMMAR EXTEND Gram | -> { VernacFlagEmpty } ] ] ; - vernac: - [ [ IDENT "Local"; v = vernac_poly -> { let (f, v) = v in (("local", VernacFlagEmpty) :: f, v) } - | IDENT "Global"; v = vernac_poly -> { let (f, v) = v in (("global", VernacFlagEmpty) :: f, v) } - - | v = vernac_poly -> { v } ] - ] + legacy_attr: + [ [ IDENT "Local" -> + { ("local", VernacFlagEmpty) } + | IDENT "Global" -> + { ("global", VernacFlagEmpty) } + | IDENT "Polymorphic" -> + { Attributes.vernac_polymorphic_flag } + | IDENT "Monomorphic" -> + { Attributes.vernac_monomorphic_flag } + | IDENT "Cumulative" -> + { ("universes", VernacFlagList ["cumulative", VernacFlagEmpty]) } + | IDENT "NonCumulative" -> + { ("universes", VernacFlagList ["noncumulative", VernacFlagEmpty]) } + | IDENT "Private" -> + { ("private", VernacFlagList ["matching", VernacFlagEmpty]) } + | IDENT "Program" -> + { ("program", VernacFlagEmpty) } + ] ] ; - vernac_poly: - [ [ IDENT "Polymorphic"; v = vernac_aux -> - { let (f, v) = v in (Attributes.vernac_polymorphic_flag :: f, v) } - | IDENT "Monomorphic"; v = vernac_aux -> - { let (f, v) = v in (Attributes.vernac_monomorphic_flag :: f, v) } - | v = vernac_aux -> { v } ] - ] + vernac: + [ [ attrs = LIST0 legacy_attr; v = vernac_aux -> { (attrs, v) } ] ] ; vernac_aux: (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *) (* "." is still in the stream and discard_to_dot works correctly *) - [ [ IDENT "Program"; g = gallina; "." -> { (["program", VernacFlagEmpty], g) } - | IDENT "Program"; g = gallina_ext; "." -> { (["program", VernacFlagEmpty], g) } - | g = gallina; "." -> { ([], g) } - | g = gallina_ext; "." -> { ([], g) } - | c = command; "." -> { ([], c) } - | c = syntax; "." -> { ([], c) } - | c = subprf -> { ([], c) } + [ [ g = gallina; "." -> { g } + | g = gallina_ext; "." -> { g } + | c = command; "." -> { c } + | c = syntax; "." -> { c } + | c = subprf -> { c } ] ] ; vernac_aux: LAST - [ [ prfcom = command_entry -> { ([], prfcom) } ] ] + [ [ prfcom = command_entry -> { prfcom } ] ] ; noedit_mode: [ [ c = query_command -> { c None } ] ] @@ -197,9 +202,8 @@ GRAMMAR EXTEND Gram | IDENT "Let"; id = identref; b = def_body -> { VernacDefinition ((DoDischarge, Let), (lname_of_lident id, None), b) } (* Gallina inductive declarations *) - | cum = OPT cumulativity_token; priv = private_token; f = finite_token; - indl = LIST1 inductive_definition SEP "with" -> - { VernacInductive (cum, priv, f, indl) } + | f = finite_token; indl = LIST1 inductive_definition SEP "with" -> + { VernacInductive (f, indl) } | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> { VernacFixpoint (NoDischarge, recs) } | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> @@ -341,35 +345,14 @@ GRAMMAR EXTEND Gram | IDENT "Structure" -> { Structure } | IDENT "Class" -> { Class true } ] ] ; - cumulativity_token: - [ [ IDENT "Cumulative" -> { VernacCumulative } - | IDENT "NonCumulative" -> { VernacNonCumulative } ] ] - ; - private_token: - [ [ IDENT "Private" -> { true } | -> { false } ] ] - ; (* Simple definitions *) def_body: [ [ bl = binders; ":="; red = reduce; c = lconstr -> - { if List.exists (function CLocalPattern _ -> true | _ -> false) bl - then - (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = mkLambdaCN ~loc bl c in - DefineBody ([], red, c, None) - else - (match c with - | { CAst.v = CCast(c, CastConv t) } -> DefineBody (bl, red, c, Some t) - | _ -> DefineBody (bl, red, c, None)) } + { match c.CAst.v with + | CCast(c, Glob_term.CastConv t) -> DefineBody (bl, red, c, Some t) + | _ -> DefineBody (bl, red, c, None) } | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> - { let ((bl, c), tyo) = - if List.exists (function CLocalPattern _ -> true | _ -> false) bl - then - (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = CAst.make ~loc @@ CCast (c, CastConv t) in - (([],mkLambdaCN ~loc bl c), None) - else ((bl, c), Some t) - in - DefineBody (bl, red, c, tyo) } + { DefineBody (bl, red, c, Some t) } | bl = binders; ":"; t = lconstr -> { ProveBody (bl, t) } ] ] ; @@ -986,13 +969,6 @@ GRAMMAR EXTEND Gram { fun g -> VernacSearch (SearchRewrite c,g, l) } | IDENT "Search"; s = searchabout_query; l = searchabout_queries; "." -> { let (sl,m) = l in fun g -> VernacSearch (Search (s::sl),g, m) } - (* compatibility: SearchAbout *) - | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries; "." -> - { fun g -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl),g, m) } - (* compatibility: SearchAbout with "[ ... ]" *) - | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]"; - l = in_or_out_modules; "." -> - { fun g -> VernacSearch (SearchAbout sl,g, l) } ] ] ; printable: diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 07ec6ca1ba..5555a2c68e 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/himsg.mli b/vernac/himsg.mli index 9de5284393..f0aa50f227 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 80616ecc2a..7260b13ff6 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/indschemes.mli b/vernac/indschemes.mli index a747ac6598..16e3bcfb7c 100644 --- a/vernac/indschemes.mli +++ b/vernac/indschemes.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 231bdafce9..feedf4d71d 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -27,47 +27,34 @@ module Proof_ending = struct | Regular | End_obligation of DeclareObl.obligation_qed_info | End_derive of { f : Id.t; name : Id.t } - | End_equations of { hook : Constant.t list -> Evd.evar_map -> unit - ; i : Id.t - ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list - ; wits : EConstr.t list ref - (* wits are actually computed by the proof - engine by side-effect after creating the - proof! This is due to the start_dependent_proof API *) - ; sigma : Evd.evar_map - } + | End_equations of + { hook : Constant.t list -> Evd.evar_map -> unit + ; i : Id.t + ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list + ; sigma : Evd.evar_map + } end -module Recthm = struct - type t = - { name : Id.t - ; typ : Constr.t - ; args : Name.t list - ; impargs : Impargs.manual_implicits - } -end - module Info = struct type t = { hook : DeclareDef.Hook.t option - ; compute_guard : lemma_possible_guards - ; impargs : Impargs.manual_implicits ; proof_ending : Proof_ending.t CEphemeron.key (* This could be improved and the CEphemeron removed *) - ; other_thms : Recthm.t list ; scope : DeclareDef.locality ; kind : Decls.logical_kind + (* thms and compute guard are specific only to start_lemma_with_initialization + regular terminator *) + ; thms : DeclareDef.Recthm.t list + ; compute_guard : lemma_possible_guards } let make ?hook ?(proof_ending=Proof_ending.Regular) ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.(IsProof Lemma)) () = { hook ; compute_guard = [] - ; impargs = [] ; proof_ending = CEphemeron.create proof_ending - ; other_thms = [] + ; thms = [] ; scope ; kind } @@ -109,18 +96,30 @@ let initialize_named_context_for_proof () = let d = if Decls.variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val +let add_first_thm ~info ~name ~typ ~impargs = + let thms = + { DeclareDef.Recthm.name + ; impargs + ; typ = EConstr.Unsafe.to_constr typ + ; args = [] } :: info.Info.thms + in + { info with Info.thms } + (* Starting a goal *) let start_lemma ~name ~poly ?(udecl=UState.default_univ_decl) - ?(info=Info.make ()) - sigma c = + ?(info=Info.make ()) ?(impargs=[]) sigma c = (* We remove the bodies of variables in the named context marked "opaque", this is a hack tho, see #10446 *) let sign = initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in let proof = Proof_global.start_proof sigma ~name ~udecl ~poly goals in - { proof ; info } + let info = add_first_thm ~info ~name ~typ:c ~impargs in + { proof; info } +(* Note that proofs opened by start_dependent lemma cannot be closed + by the regular terminators, thus we don't need to update the [thms] + field. We will capture this invariant by typing in the future *) let start_dependent_lemma ~name ~poly ?(udecl=UState.default_univ_decl) ?(info=Info.make ()) telescope = @@ -129,7 +128,7 @@ let start_dependent_lemma ~name ~poly let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun { Recthm.name; typ } -> name, (EConstr.of_constr typ)) thms with + match List.map (fun { DeclareDef.Recthm.name; typ } -> name, (EConstr.of_constr typ)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -137,42 +136,45 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun { Recthm.name; typ } n -> (name, n, (EConstr.of_constr typ))) thms nl with + in match List.map2 (fun { DeclareDef.Recthm.name; typ } n -> (name, n, (EConstr.of_constr typ))) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recguard thms snl = - let intro_tac { Recthm.args; _ } = Tactics.auto_intros_tac args in + let intro_tac { DeclareDef.Recthm.args; _ } = Tactics.auto_intros_tac args in let init_tac, compute_guard = match recguard with - | Some (finite,guard,init_tac) -> + | Some (finite,guard,init_terms) -> let rec_tac = rec_tac_initializer finite guard thms snl in - Some (match init_tac with - | None -> - Tacticals.New.tclTHENS rec_tac (List.map intro_tac thms) - | Some tacl -> - Tacticals.New.tclTHENS rec_tac - List.(map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms) - ),guard + let term_tac = + match init_terms with + | None -> + List.map intro_tac thms + | Some init_terms -> + (* This is the case for hybrid proof mode / definition + fixpoint, where terms for some constants are given with := *) + let tacl = List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) init_terms in + List.map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms + in + Tacticals.New.tclTHENS rec_tac term_tac, guard | None -> let () = match thms with [_] -> () | _ -> assert false in - Some (intro_tac (List.hd thms)), [] in + intro_tac (List.hd thms), [] in match thms with | [] -> CErrors.anomaly (Pp.str "No proof to start.") - | { Recthm.name; typ; impargs; _}::other_thms -> + | { DeclareDef.Recthm.name; typ; impargs; _} :: thms -> let info = Info.{ hook - ; impargs ; compute_guard - ; other_thms ; proof_ending = CEphemeron.create Proof_ending.Regular + ; thms ; scope ; kind } in - let lemma = start_lemma ~name ~poly ~udecl ~info sigma (EConstr.of_constr typ) in + (* start_lemma has the responsibility to add (name, impargs, typ) + to thms, once Info.t is more refined this won't be necessary *) + let lemma = start_lemma ~name ~impargs ~poly ~udecl ~info sigma (EConstr.of_constr typ) in pf_map (Proof_global.map_proof (fun p -> - match init_tac with - | None -> p - | Some tac -> pi1 @@ Proof.run_tactic Global.(env ()) tac p)) lemma + pi1 @@ Proof.run_tactic Global.(env ()) init_tac p)) lemma (************************************************************************) (* Commom constant saving path, for both Qed and Admitted *) @@ -183,46 +185,22 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua (* XXX: Most of this does belong to Declare, due to proof_entry manip *) module MutualEntry : sig - (* We keep this type abstract and to avoid uncontrolled hacks *) - type t - - val variable : info:Info.t -> Entries.parameter_entry -> t - - val adjust_guardness_conditions + val declare_variable : info:Info.t - -> Evd.side_effects Declare.proof_entry - -> t + -> uctx:UState.t + -> Entries.parameter_entry + -> Names.GlobRef.t list val declare_mutdef (* Common to all recthms *) - : ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) - -> poly:bool + : info:Info.t -> uctx:UState.t - -> ?hook_data:DeclareDef.Hook.t * UState.t * (Names.Id.t * Constr.t) list - -> udecl:UState.universe_decl - (* Only for the first constant, introduced by compat *) - -> ubind:UnivNames.universe_binders - -> name:Id.t - -> t + -> Evd.side_effects Declare.proof_entry -> Names.GlobRef.t list end = struct - (* Body with the fix *) - type et = - | NoBody of Entries.parameter_entry - | Single of Evd.side_effects Declare.proof_entry - | Mutual of Evd.side_effects Declare.proof_entry - - type t = - { entry : et - ; info : Info.t - } - - let variable ~info t = { entry = NoBody t; info } - - (* XXX: Refactor this with the code in - [ComFixpoint.declare_fixpoint_generic] *) + (* XXX: Refactor this with the code in [DeclareDef.declare_mutdef] *) let guess_decreasing env possible_indexes ((body, ctx), eff) = let open Constr in match Constr.kind body with @@ -232,66 +210,56 @@ end = struct (mkFix ((indexes,0),fixdecls), ctx), eff | _ -> (body, ctx), eff - let adjust_guardness_conditions ~info const = - let entry = match info.Info.compute_guard with - | [] -> - (* Not a recursive statement *) - Single const - | possible_indexes -> - (* Try all combinations... not optimal *) - let env = Global.env() in - let pe = Declare.Internal.map_entry_body const - ~f:(guess_decreasing env possible_indexes) - in - Mutual pe - in { entry; info } - - let rec select_body i t = + let select_body i t = let open Constr in match Constr.kind t with | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) | CoFix (0,decls) -> mkCoFix (i,decls) - | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, select_body i t2) - | Lambda(na,ty,t) -> mkLambda(na,ty, select_body i t) - | App (t, args) -> mkApp (select_body i t, args) | _ -> CErrors.anomaly Pp.(str "Not a proof by induction: " ++ Termops.Internal.debug_print_constr (EConstr.of_constr t) ++ str ".") - let declare_mutdef ?fix_exn ~poly ~uctx ?hook_data ~udecl ~ubind ~name ?typ ~impargs ~info mutpe i = - let { Info.hook; compute_guard; scope; kind; _ } = info in - match mutpe with - | NoBody pe -> - DeclareDef.declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe - | Single pe -> - (* We'd like to do [assert (i = 0)] here, however this codepath - is used when declaring mutual cofixpoints *) - DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ubind pe impargs - | Mutual pe -> - (* if typ = None , we don't touch the type; used in the base case *) - let pe = - match typ with - | None -> pe - | Some typ -> - Declare.Internal.map_entry_type pe ~f:(fun _ -> Some typ) - in - let pe = Declare.Internal.map_entry_body pe - ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) in - DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ubind pe impargs - - let declare_mutdef ?fix_exn ~poly ~uctx ?hook_data ~udecl ~ubind ~name { entry; info } = - (* At some point make this a single iteration *) - (* impargs here are special too, fixed in upcoming PRs *) - let impargs = info.Info.impargs in - let r = declare_mutdef ?fix_exn ~poly ~info ~udecl ~ubind ?hook_data ~uctx ~name ~impargs entry 0 in - (* Before we used to do this, check if that's right *) - let ubind = UnivNames.empty_binders in - let rs = - List.map_i ( - fun i { Recthm.name; typ; impargs } -> - declare_mutdef ?fix_exn ~poly ~udecl ~info ~ubind ?hook_data ~uctx ~name ~typ ~impargs entry i) 1 info.Info.other_thms - in r :: rs + let declare_mutdef ~uctx ~info pe i DeclareDef.Recthm.{ name; impargs; typ; _} = + let { Info.hook; scope; kind; compute_guard; _ } = info in + (* if i = 0 , we don't touch the type; this is for compat + but not clear it is the right thing to do. + *) + let pe, ubind = + if i > 0 && not (CList.is_empty compute_guard) + then Declare.Internal.map_entry_type pe ~f:(fun _ -> Some typ), UnivNames.empty_binders + else pe, UState.universe_binders uctx + in + (* We when compute_guard was [] in the previous step we should not + substitute the body *) + let pe = match compute_guard with + | [] -> pe + | _ -> + Declare.Internal.map_entry_body pe + ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) + in + DeclareDef.declare_entry ~name ~scope ~kind ?hook ~impargs ~uctx pe + + let declare_mutdef ~info ~uctx const = + let pe = match info.Info.compute_guard with + | [] -> + (* Not a recursive statement *) + const + | possible_indexes -> + (* Try all combinations... not optimal *) + let env = Global.env() in + Declare.Internal.map_entry_body const + ~f:(guess_decreasing env possible_indexes) + in + List.map_i (declare_mutdef ~info ~uctx pe) 0 info.Info.thms + + let declare_variable ~info ~uctx pe = + let { Info.scope; hook } = info in + List.map_i ( + fun i { DeclareDef.Recthm.name; typ; impargs } -> + DeclareDef.declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + ) 0 info.Info.thms + end (************************************************************************) @@ -318,16 +286,13 @@ let compute_proof_using_for_admitted proof typ pproofs = Some (Environ.really_needed env (Id.Set.union ids_typ ids_def)) | _ -> None -let finish_admitted ~name ~poly ~info ~uctx ~udecl pe = - let mutpe = MutualEntry.variable ~info pe in - let ubind = UnivNames.empty_binders in - let _r : Names.GlobRef.t list = - MutualEntry.declare_mutdef ~uctx ~poly ~udecl ~ubind ~name mutpe in +let finish_admitted ~info ~uctx pe = + let _r : Names.GlobRef.t list = MutualEntry.declare_variable ~info ~uctx pe in () let save_lemma_admitted ~(lemma : t) : unit = let udecl = Proof_global.get_universe_decl lemma.proof in - let Proof.{ name; poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in + let Proof.{ poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in let typ = match Proofview.initial_goals entry with | [typ] -> snd typ | _ -> CErrors.anomaly ~label:"Lemmas.save_lemma_admitted" (Pp.str "more than one statement.") @@ -336,49 +301,26 @@ let save_lemma_admitted ~(lemma : t) : unit = let proof = Proof_global.get_proof lemma.proof in let pproofs = Proof.partial_proof proof in let sec_vars = compute_proof_using_for_admitted lemma.proof typ pproofs in - let universes = Proof_global.get_initial_euctx lemma.proof in - let ctx = UState.check_univ_decl ~poly universes udecl in - finish_admitted ~name ~poly ~info:lemma.info ~uctx:universes ~udecl (sec_vars, (typ, ctx), None) + let uctx = Proof_global.get_initial_euctx lemma.proof in + let univs = UState.check_univ_decl ~poly uctx udecl in + finish_admitted ~info:lemma.info ~uctx (sec_vars, (typ, univs), None) (************************************************************************) (* Saving a lemma-like constant *) (************************************************************************) -let default_thm_id = Id.of_string "Unnamed_thm" - -let check_anonymity id save_ident = - if not (String.equal (Nameops.atompart_of_id id) (Id.to_string (default_thm_id))) then - CErrors.user_err Pp.(str "This command can only be used for unnamed theorem.") - -let finish_proved idopt po info = +let finish_proved po info = let open Proof_global in - let { Info.hook } = info in match po with - | { name; entries=[const]; universes; udecl; poly } -> - let name = match idopt with - | None -> name - | Some { CAst.v = save_id } -> check_anonymity name save_id; save_id in - let fix_exn = Declare.Internal.get_fix_exn const in - let () = try - let mutpe = MutualEntry.adjust_guardness_conditions ~info const in - let hook_data = Option.map (fun hook -> hook, universes, []) hook in - let ubind = UState.universe_binders universes in - let _r : Names.GlobRef.t list = - MutualEntry.declare_mutdef ~fix_exn ~uctx:universes ~poly ~udecl ?hook_data ~ubind ~name mutpe - in () - with e when CErrors.noncritical e -> - let e = Exninfo.capture e in - Exninfo.iraise (fix_exn e) - in () + | { entries=[const]; uctx } -> + let _r : Names.GlobRef.t list = MutualEntry.declare_mutdef ~info ~uctx const in + () | _ -> CErrors.anomaly ~label:"finish_proved" Pp.(str "close_proof returned more than one proof term") -let finish_derived ~f ~name ~idopt ~entries = +let finish_derived ~f ~name ~entries = (* [f] and [name] correspond to the proof of [f] and of [suchthat], respectively. *) - if Option.has_some idopt then - CErrors.user_err Pp.(str "Cannot save a proof of Derive with an explicit name."); - let f_def, lemma_def = match entries with | [_;f_def;lemma_def] -> @@ -411,11 +353,11 @@ let finish_derived ~f ~name ~idopt ~entries = let _ : Names.Constant.t = Declare.declare_constant ~name ~kind:Decls.(IsProof Proposition) lemma_def in () -let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = +let finish_proved_equations ~kind ~hook i proof_obj types sigma0 = let obls = ref 1 in let sigma, recobls = - CList.fold_left2_map (fun sigma (wit, (evar_env, ev, evi, local_context, type_)) entry -> + CList.fold_left2_map (fun sigma (_evar_env, ev, _evi, local_context, _type) entry -> let id = match Evd.evar_ident ev sigma0 with | Some id -> id @@ -426,34 +368,51 @@ let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = let sigma, app = Evarutil.new_global sigma (GlobRef.ConstRef cst) in let sigma = Evd.define ev (EConstr.applist (app, List.map EConstr.of_constr args)) sigma in sigma, cst) sigma0 - (CList.combine (List.rev !wits) types) proof_obj.Proof_global.entries + types proof_obj.Proof_global.entries in hook recobls sigma -let finalize_proof idopt proof_obj proof_info = +let finalize_proof proof_obj proof_info = let open Proof_global in let open Proof_ending in match CEphemeron.default proof_info.Info.proof_ending Regular with | Regular -> - finish_proved idopt proof_obj proof_info + finish_proved proof_obj proof_info | End_obligation oinfo -> - DeclareObl.obligation_terminator proof_obj.entries proof_obj.universes oinfo + DeclareObl.obligation_terminator proof_obj.entries proof_obj.uctx oinfo | End_derive { f ; name } -> - finish_derived ~f ~name ~idopt ~entries:proof_obj.entries - | End_equations { hook; i; types; wits; sigma } -> - finish_proved_equations idopt proof_info.Info.kind proof_obj hook i types wits sigma + finish_derived ~f ~name ~entries:proof_obj.entries + | End_equations { hook; i; types; sigma } -> + finish_proved_equations ~kind:proof_info.Info.kind ~hook i proof_obj types sigma + +let err_save_forbidden_in_place_of_qed () = + CErrors.user_err (Pp.str "Cannot use Save with more than one constant or in this proof mode") + +let process_idopt_for_save ~idopt info = + match idopt with + | None -> info + | Some { CAst.v = save_name } -> + (* Save foo was used; we override the info in the first theorem *) + let thms = + match info.Info.thms, CEphemeron.default info.Info.proof_ending Proof_ending.Regular with + | [ { DeclareDef.Recthm.name; _} as decl ], Proof_ending.Regular -> + [ { decl with DeclareDef.Recthm.name = save_name } ] + | _ -> + err_save_forbidden_in_place_of_qed () + in { info with Info.thms } let save_lemma_proved ~lemma ~opaque ~idopt = (* Env and sigma are just used for error printing in save_remaining_recthms *) let proof_obj = Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) lemma.proof in - finalize_proof idopt proof_obj lemma.info + let proof_info = process_idopt_for_save ~idopt lemma.info in + finalize_proof proof_obj proof_info (***********************************************************************) (* Special case to close a lemma without forcing a proof *) (***********************************************************************) let save_lemma_admitted_delayed ~proof ~info = let open Proof_global in - let { name; entries; universes; udecl; poly } = proof in + let { entries; uctx } = proof in if List.length entries <> 1 then CErrors.user_err Pp.(str "Admitted does not support multiple statements"); let { Declare.proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in @@ -463,8 +422,16 @@ let save_lemma_admitted_delayed ~proof ~info = let typ = match proof_entry_type with | None -> CErrors.user_err Pp.(str "Admitted requires an explicit statement"); | Some typ -> typ in - let ctx = UState.univ_entry ~poly universes in + let ctx = UState.univ_entry ~poly uctx in let sec_vars = if get_keep_admitted_vars () then proof_entry_secctx else None in - finish_admitted ~name ~poly ~uctx:universes ~udecl ~info (sec_vars, (typ, ctx), None) - -let save_lemma_proved_delayed ~proof ~info ~idopt = finalize_proof idopt proof info + finish_admitted ~uctx ~info (sec_vars, (typ, ctx), None) + +let save_lemma_proved_delayed ~proof ~info ~idopt = + (* vio2vo calls this but with invalid info, we have to workaround + that to add the name to the info structure *) + if CList.is_empty info.Info.thms then + let info = add_first_thm ~info ~name:proof.Proof_global.name ~typ:EConstr.mkSet ~impargs:[] in + finalize_proof proof info + else + let info = process_idopt_for_save ~idopt info in + finalize_proof proof info diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index d645de1ceb..8a23daa85f 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -35,28 +35,15 @@ module Proof_ending : sig | Regular | End_obligation of DeclareObl.obligation_qed_info | End_derive of { f : Id.t; name : Id.t } - | End_equations of { hook : Constant.t list -> Evd.evar_map -> unit - ; i : Id.t - ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list - ; wits : EConstr.t list ref - ; sigma : Evd.evar_map - } + | End_equations of + { hook : Constant.t list -> Evd.evar_map -> unit + ; i : Id.t + ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list + ; sigma : Evd.evar_map + } end -module Recthm : sig - type t = - { name : Id.t - (** Name of theorem *) - ; typ : Constr.t - (** Type of theorem *) - ; args : Name.t list - (** Names to pre-introduce *) - ; impargs : Impargs.manual_implicits - (** Explicitily declared implicit arguments *) - } -end - module Info : sig type t @@ -81,6 +68,7 @@ val start_lemma -> poly:bool -> ?udecl:UState.universe_decl -> ?info:Info.t + -> ?impargs:Impargs.manual_implicits -> Evd.evar_map -> EConstr.types -> t @@ -95,7 +83,7 @@ val start_dependent_lemma type lemma_possible_guards = int list list -(** Pretty much internal, only used in ComFixpoint *) +(** Pretty much internal, used by the Lemma / Fixpoint vernaculars *) val start_lemma_with_initialization : ?hook:DeclareDef.Hook.t -> poly:bool @@ -103,13 +91,11 @@ val start_lemma_with_initialization -> kind:Decls.logical_kind -> udecl:UState.universe_decl -> Evd.evar_map - -> (bool * lemma_possible_guards * unit Proofview.tactic list option) option - -> Recthm.t list + -> (bool * lemma_possible_guards * Constr.t option list option) option + -> DeclareDef.Recthm.t list -> int list option -> t -val default_thm_id : Names.Id.t - (** {4 Saving proofs} *) val save_lemma_admitted : lemma:t -> unit diff --git a/vernac/library.ml b/vernac/library.ml index 5aff86c50c..7c629b08e7 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -103,17 +103,13 @@ type library_summary = { libsum_digests : Safe_typing.vodigest; } -module LibraryOrdered = DirPath -module LibraryMap = Map.Make(LibraryOrdered) -module LibraryFilenameMap = Map.Make(LibraryOrdered) - (* This is a map from names to loaded libraries *) -let libraries_table : library_summary LibraryMap.t ref = - Summary.ref LibraryMap.empty ~name:"LIBRARY" +let libraries_table : library_summary DPmap.t ref = + Summary.ref DPmap.empty ~name:"LIBRARY" (* This is the map of loaded libraries filename *) (* (not synchronized so as not to be caught in the states on disk) *) -let libraries_filename_table = ref LibraryFilenameMap.empty +let libraries_filename_table = ref DPmap.empty (* These are the _ordered_ sets of loaded, imported and exported libraries *) let libraries_loaded_list = Summary.ref [] ~name:"LIBRARY-LOAD" @@ -121,7 +117,7 @@ let libraries_loaded_list = Summary.ref [] ~name:"LIBRARY-LOAD" (* various requests to the tables *) let find_library dir = - LibraryMap.find dir !libraries_table + DPmap.find dir !libraries_table let try_find_library dir = try find_library dir @@ -133,16 +129,16 @@ let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) (* from a previous play of the session *) libraries_filename_table := - LibraryFilenameMap.add dir f !libraries_filename_table + DPmap.add dir f !libraries_filename_table let library_full_filename dir = - try LibraryFilenameMap.find dir !libraries_filename_table + try DPmap.find dir !libraries_filename_table with Not_found -> "<unavailable filename>" let overwrite_library_filenames f = let f = if Filename.is_relative f then Filename.concat (Sys.getcwd ()) f else f in - LibraryMap.iter (fun dir _ -> register_library_filename dir f) + DPmap.iter (fun dir _ -> register_library_filename dir f) !libraries_table let library_is_loaded dir = @@ -167,7 +163,7 @@ let register_loaded_library m = | m'::_ as l when DirPath.equal m' libname -> l | m'::l' -> m' :: aux l' in libraries_loaded_list := aux !libraries_loaded_list; - libraries_table := LibraryMap.add libname m !libraries_table + libraries_table := DPmap.add libname m !libraries_table let loaded_libraries () = !libraries_loaded_list @@ -187,13 +183,13 @@ type 'a table_status = | Fetched of 'a array let opaque_tables = - ref (LibraryMap.empty : (Opaqueproof.opaque_proofterm table_status) LibraryMap.t) + ref (DPmap.empty : (Opaqueproof.opaque_proofterm table_status) DPmap.t) let add_opaque_table dp st = - opaque_tables := LibraryMap.add dp st !opaque_tables + opaque_tables := DPmap.add dp st !opaque_tables let access_table what tables dp i = - let t = match LibraryMap.find dp !tables with + let t = match DPmap.find dp !tables with | Fetched t -> t | ToFetch f -> let dir_path = Names.DirPath.to_string dp in @@ -206,7 +202,7 @@ let access_table what tables dp i = str ") is inaccessible or corrupted,\ncannot load some " ++ str what ++ str " in it.\n") in - tables := LibraryMap.add dp (Fetched t) !tables; + tables := DPmap.add dp (Fetched t) !tables; t in assert (i < Array.length t); t.(i) @@ -261,14 +257,12 @@ let intern_from_file f = | Some (_,false) -> mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty -module DPMap = Map.Make(DirPath) - let rec intern_library ~lib_resolver (needed, contents) (dir, f) from = (* Look if in the current logical environment *) try (find_library dir).libsum_digests, (needed, contents) with Not_found -> (* Look if already listed and consequently its dependencies too *) - try (DPMap.find dir contents).library_digests, (needed, contents) + try (DPmap.find dir contents).library_digests, (needed, contents) with Not_found -> Feedback.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* [dir] is an absolute name which matches [f] which must be in loadpath *) @@ -286,7 +280,7 @@ and intern_library_deps ~lib_resolver libs dir m from = let needed, contents = Array.fold_left (intern_mandatory_library ~lib_resolver dir from) libs m.library_deps in - (dir :: needed, DPMap.add dir m contents ) + (dir :: needed, DPmap.add dir m contents ) and intern_mandatory_library ~lib_resolver caller from libs (dir,d) = let digest, libs = intern_library ~lib_resolver libs (dir, None) (Some from) in @@ -372,8 +366,8 @@ let warn_require_in_module = strbrk "and optionally Import it inside another one.") let require_library_from_dirpath ~lib_resolver modrefl export = - let needed, contents = List.fold_left (rec_intern_library ~lib_resolver) ([], DPMap.empty) modrefl in - let needed = List.rev_map (fun dir -> DPMap.find dir contents) needed in + let needed, contents = List.fold_left (rec_intern_library ~lib_resolver) ([], DPmap.empty) modrefl in + let needed = List.rev_map (fun dir -> DPmap.find dir contents) needed in let modrefl = List.map fst modrefl in if Lib.is_module_or_modtype () then begin @@ -500,14 +494,11 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = let save_library_raw f sum lib univs proofs = save_library_base f sum lib (Some univs) None proofs -module StringOrd = struct type t = string let compare = String.compare end -module StringSet = Set.Make(StringOrd) - let get_used_load_paths () = - StringSet.elements - (List.fold_left (fun acc m -> StringSet.add + String.Set.elements + (List.fold_left (fun acc m -> String.Set.add (Filename.dirname (library_full_filename m)) acc) - StringSet.empty !libraries_loaded_list) + String.Set.empty !libraries_loaded_list) let _ = Nativelib.get_load_paths := get_used_load_paths diff --git a/vernac/library.mli b/vernac/library.mli index ec485e6408..633d266821 100644 --- a/vernac/library.mli +++ b/vernac/library.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/loadpath.ml b/vernac/loadpath.ml index 38aa42c349..d2df99e821 100644 --- a/vernac/loadpath.ml +++ b/vernac/loadpath.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/loadpath.mli b/vernac/loadpath.mli index 68212b9a47..cfd2becdc4 100644 --- a/vernac/loadpath.mli +++ b/vernac/loadpath.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/locality.ml b/vernac/locality.ml index c31f722a61..9e784c8bb3 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/locality.mli b/vernac/locality.mli index eda754324a..26149cb394 100644 --- a/vernac/locality.mli +++ b/vernac/locality.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 10946d78f0..475d5c31f7 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -252,7 +252,7 @@ let quote_notation_token x = let is_numeral symbs = match List.filter (function Break _ -> false | _ -> true) symbs with | ([Terminal "-"; Terminal x] | [Terminal x]) -> - NumTok.of_string x <> None + NumTok.Unsigned.parse_string x <> None | _ -> false diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index d76820b033..dd71817083 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 671dae7876..d276a1ac35 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/mltop.mli b/vernac/mltop.mli index 633a5c241d..b257fe7890 100644 --- a/vernac/mltop.mli +++ b/vernac/mltop.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 27eb821a6a..435085793c 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * 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) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,253 +10,15 @@ open Printf -(** - - 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 Constr -open Vars open Names -open Evd open Pp open CErrors open Util -module NamedDecl = Context.Named.Declaration - +(* For the records fields, opens should go away one these types are private *) open DeclareObl - -let succfix (depth, fixrels) = - (succ depth, List.map succ fixrels) - -let check_evars env evm = - Evar.Map.iter - (fun key evi -> - if Evd.is_obligation_evar evm key then () - else - let (loc,k) = evar_source key evm in - Pretype_errors.error_unsolvable_implicit ?loc env evm key None) - (Evd.undefined_map evm) - -type oblinfo = - { ev_name: int * Id.t; - ev_hyps: EConstr.named_context; - 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 evm evs n idf t = - 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 EConstr.kind evm 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 = - let open Context.Named.Declaration in - 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 EConstr.kind evm x with - | Rel n -> Int.List.mem n fixrels - | _ -> false) args - then - transparent := Id.Set.add idstr !transparent; - EConstr.mkApp (idf idstr, Array.of_list args) - | Fix _ -> - EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c - | _ -> EConstr.map_with_binders evm succfix substrec (depth, fixrels) c - in - let t' = substrec (0, []) t in - EConstr.to_constr evm 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 Constr.kind c with - | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) - | _ -> Constr.map_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 evm evs hyps concl = - let open Context.Named.Declaration in - let rec aux acc n = function - decl :: tl -> - let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar (NamedDecl.get_type decl) in - let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (NamedDecl.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 evm evs n EConstr.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 evm evs n EConstr.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 = - let pop t = Vars.lift (-1) t in - if Int.equal n 0 then Some t - else - match Constr.kind t with - | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (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 evm evi in - if Evar.Set.mem oev deps' then - invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ Pp.string_of_ppcmds @@ Evar.print 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 evm 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 { Evar_kinds.qm_obligation=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 evm evts 0 EConstr.mkVar t - in - let ty, _, _ = subst_evar_constr evm evts 0 EConstr.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 evm evts 0 f c) in - Array.of_list (List.rev evars), (evnames, evmap), t', ty +open DeclareObl.Obligation +open DeclareObl.ProgramDecl let pperror cmd = CErrors.user_err ~hdr:"Program" cmd let error s = pperror (str s) @@ -272,84 +34,35 @@ 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 * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) - * Int.Set.t * unit Proofview.tactic option) array - let assumption_message = Declare.assumption_message let default_tactic = ref (Proofview.tclUNIT ()) -let evar_of_obligation o = make_evar (Global.named_context_val ()) (EConstr.of_constr o.obl_type) +let evar_of_obligation o = Evd.make_evar (Global.named_context_val ()) (EConstr.of_constr o.obl_type) let subst_deps expand obls deps t = - let osubst = obl_substitution expand obls deps in + let osubst = DeclareObl.obl_substitution expand obls deps in (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) let subst_deps_obl obls obl = let t' = subst_deps true obls obl.obl_deps obl.obl_type in - { obl with obl_type = t' } + Obligation.set_type ~typ:t' obl open Evd -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 init_prog_info ?(opaque = false) ?hook n udecl b t ctx deps fixkind - notations obls impls ~scope ~poly ~kind reduce = - 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.tag 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 - let ctx = UState.make_flexible_nonalgebraic ctx in - { prg_name = n - ; prg_body = b - ; prg_type = reduce t - ; prg_ctx = ctx - ; prg_univdecl = udecl - ; prg_obligations = (obls', Array.length obls') - ; prg_deps = deps - ; prg_fixkind = fixkind - ; prg_notations = notations - ; prg_implicits = impls - ; prg_poly = poly - ; prg_scope = scope - ; prg_kind = kind - ; prg_reduce = reduce - ; prg_hook = hook - ; prg_opaque = opaque - } - 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; + if (CEphemeron.get v).prg_obligations.remaining > 0 then incr i) m; !i -exception Found of program_info CEphemeron.key +exception Found of ProgramDecl.t CEphemeron.key let map_first m = try ProgMap.iter (fun _ v -> - if snd (CEphemeron.get v).prg_obligations > 0 then - raise (Found v)) m; + if (CEphemeron.get v).prg_obligations.remaining > 0 then + raise (Found v)) m; assert(false) with Found x -> x @@ -416,16 +129,14 @@ let warn_solve_errored = CWarnings.create ~name:"solve_obligation_error" ~catego Pp.seq [str "Solve Obligations tactic returned error: "; err; fnl (); str "This will become an error in the future"]) -let solve_by_tac ?loc name evi t poly ctx = - (* spiwack: the status is dropped. *) +let solve_by_tac ?loc name evi t poly uctx = try - let (entry,_,ctx') = - Pfedit.build_constant_by_tactic - ~name ~poly ctx evi.evar_hyps evi.evar_concl t in + (* the status is dropped. *) let env = Global.env () in - let body, ctx' = Declare.inline_private_constants ~univs:ctx' env entry in - Inductiveops.control_only_guard env (Evd.from_ctx ctx') (EConstr.of_constr body); - Some (body, entry.Declare.proof_entry_type, ctx') + let body, types, _, uctx = + Pfedit.build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in + Inductiveops.control_only_guard env (Evd.from_ctx uctx) (EConstr.of_constr body); + Some (body, types, uctx) with | Refiner.FailError (_, s) as exn -> let _ = Exninfo.capture exn in @@ -438,43 +149,9 @@ let solve_by_tac ?loc name evi t poly ctx = warn_solve_errored ?loc err; None -let obligation_hook prg obl num auto { DeclareDef.Hook.S.uctx = ctx'; dref; _ } = - let obls, rem = prg.prg_obligations in - let cst = match dref with GlobRef.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 inst, ctx' = - if not prg.prg_poly (* Not polymorphic *) then - (* The universe context was declared globally, we continue - from the new global environment. *) - let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in - let ctx' = UState.merge_subst ctx (UState.subst ctx') in - Univ.Instance.empty, ctx' - else - (* We get the right order somehow, but surely it could be enforced in a clearer way. *) - let uctx = UState.context ctx' in - Univ.UContext.instance uctx, ctx' - in - let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in - let () = if transparent then add_hint true prg cst in - let obls = Array.copy obls in - let () = obls.(num) <- obl in - let prg = { prg with prg_ctx = ctx' } in - let () = ignore (update_obls prg obls (pred rem)) 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) deps None) - end - let rec solve_obligation prg num tac = let user_num = succ num in - let obls, rem = prg.prg_obligations in + let { obls; remaining=rem } = prg.prg_obligations in let obl = obls.(num) in let remaining = deps_remaining obls obl.obl_deps in let () = @@ -491,7 +168,7 @@ let rec solve_obligation prg num tac = let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n oblset tac = auto_solve_obligations n ~oblset tac in let proof_ending = Lemmas.Proof_ending.End_obligation (DeclareObl.{name = prg.prg_name; num; auto}) in - let hook = DeclareDef.Hook.make (obligation_hook prg obl num auto) in + let hook = DeclareDef.Hook.make (DeclareObl.obligation_hook prg obl num auto) in let info = Lemmas.Info.make ~hook ~proof_ending ~scope ~kind () in let poly = prg.prg_poly in let lemma = Lemmas.start_lemma ~name:obl.obl_name ~poly ~info evd (EConstr.of_constr obl.obl_type) in @@ -502,7 +179,7 @@ let rec solve_obligation prg num 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 + let { obls; remaining } = prg.prg_obligations in if num >= 0 && num < Array.length obls then let obl = obls.(num) in match obl.obl_body with @@ -532,8 +209,9 @@ and solve_obligation_by_tac prg obls i tac = prg.prg_poly (Evd.evar_universe_context evd) with | None -> None | Some (t, ty, ctx) -> + let prg = ProgramDecl.set_uctx ~uctx:ctx prg in + (* Why is uctx not used above? *) let uctx = UState.univ_entry ~poly:prg.prg_poly 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 prg.prg_poly then ( @@ -541,13 +219,13 @@ and solve_obligation_by_tac prg obls i tac = 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'}) + Some (ProgramDecl.set_uctx ~uctx:ctx' prg)) else Some prg else None and solve_prg_obligations prg ?oblset tac = - let obls, rem = prg.prg_obligations in - let rem = ref rem in + let { obls; remaining } = prg.prg_obligations in + let rem = ref remaining in let obls' = Array.copy obls in let set = ref Int.Set.empty in let p = match oblset with @@ -555,20 +233,20 @@ and solve_prg_obligations prg ?oblset tac = | Some s -> set := s; (fun i -> Int.Set.mem i !set) in - let prgref = ref prg in - let () = - Array.iteri (fun i x -> + let prg = + Array.fold_left_i (fun i prg 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' + match solve_obligation_by_tac prg obls' i tac with + | None -> prg + | Some prg -> + let deps = dependencies obls i in + set := Int.Set.union !set deps; + decr rem; + prg + else prg) + prg obls' in - update_obls !prgref obls' !rem + update_obls prg obls' !rem and solve_obligations n tac = let prg = get_prog_err n in @@ -579,10 +257,10 @@ and solve_all_obligations tac = and try_solve_obligation n prg tac = let prg = get_prog prg in - let obls, rem = prg.prg_obligations in + let {obls; remaining } = 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)) + | Some prg' -> ignore(update_obls prg' obls' (pred remaining)) | None -> () and try_solve_obligations n tac = @@ -595,9 +273,9 @@ and auto_solve_obligations n ?oblset tac : progress = open Pp let show_obligations_of_prg ?(msg=true) prg = let n = prg.prg_name in - let obls, rem = prg.prg_obligations in + let {obls; remaining} = prg.prg_obligations in let showed = ref 5 in - if msg then Feedback.msg_info (int rem ++ str " obligation(s) remaining: "); + if msg then Feedback.msg_info (int remaining ++ str " obligation(s) remaining: "); Array.iteri (fun i x -> match x.obl_body with | None -> @@ -630,12 +308,12 @@ let show_term n = Printer.pr_constr_env env sigma prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env env sigma prg.prg_body) -let add_definition ~name ?term t ctx ?(univdecl=UState.default_univ_decl) - ?(implicits=[]) ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?tactic +let add_definition ~name ?term t ~uctx ?(udecl=UState.default_univ_decl) + ?(impargs=[]) ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?tactic ?(reduce=reduce) ?hook ?(opaque = false) obls = let info = Id.print name ++ str " has type-checked" in - let prg = init_prog_info ~opaque name univdecl term t ctx [] None [] obls implicits ~poly ~scope ~kind reduce ?hook in - let obls,_ = prg.prg_obligations in + let prg = ProgramDecl.make ~opaque name ~udecl term t ~uctx [] None [] obls ~impargs ~poly ~scope ~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 = DeclareObl.declare_definition prg in @@ -649,15 +327,15 @@ let add_definition ~name ?term t ctx ?(univdecl=UState.default_univ_decl) | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some name)) (); res | _ -> res) -let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic +let add_mutual_definitions l ~uctx ?(udecl=UState.default_univ_decl) ?tactic ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?(reduce=reduce) ?hook ?(opaque = false) notations fixkind = - let deps = List.map (fun (n, b, t, imps, obls) -> n) l in + let deps = List.map (fun ({ DeclareDef.Recthm.name; _ }, _, _) -> name) l in List.iter - (fun (n, b, t, imps, obls) -> - let prg = init_prog_info ~opaque n univdecl (Some b) t ctx deps (Some fixkind) - notations obls imps ~poly ~scope ~kind reduce ?hook - in progmap_add n (CEphemeron.create prg)) l; + (fun ({ DeclareDef.Recthm.name; typ; impargs; _ }, b, obls) -> + let prg = ProgramDecl.make ~opaque name ~udecl (Some b) typ ~uctx deps (Some fixkind) + notations obls ~impargs ~poly ~scope ~kind reduce ?hook + in progmap_add name (CEphemeron.create prg)) l; let _defined = List.fold_left (fun finished x -> if finished then finished @@ -672,7 +350,7 @@ let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic in () let admit_prog prg = - let obls, rem = prg.prg_obligations in + let {obls; remaining} = prg.prg_obligations in let obls = Array.copy obls in Array.iteri (fun i x -> @@ -684,10 +362,10 @@ let admit_prog prg = (Declare.ParameterEntry (None,(x.obl_type,ctx),None)) ~kind:Decls.(IsAssumption Conjectural) in assumption_message x.obl_name; - obls.(i) <- { x with obl_body = Some (DefinedObl (kn, Univ.Instance.empty)) } + obls.(i) <- Obligation.set_body ~body:(DefinedObl (kn, Univ.Instance.empty)) x | Some _ -> ()) obls; - ignore(update_obls prg obls 0) + ignore(DeclareObl.update_obls prg obls 0) let rec admit_all_obligations () = let prg = try Some (get_any_prog ()) with NoObligations _ -> None in @@ -709,7 +387,7 @@ let next_obligation n tac = | None -> get_any_prog_err () | Some _ -> get_prog_err n in - let obls, rem = prg.prg_obligations in + let {obls; remaining} = 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 diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 2a0d0aba97..f42d199e18 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -1,59 +1,81 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \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) *) (************************************************************************) -open Environ open Constr -open Evd -open Names - -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 - -(* ident, type, location, (opaque or transparent, expand or define), dependencies, tactic to solve it *) -type obligation_info = - (Id.t * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array - -(* 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 - -> EConstr.constr - -> EConstr.types - -> obligation_info * - - (* Existential key, obl. name, type as product, location of the - original evar, associated tactic, status and dependencies as - indexes into the array *) - ((Evar.t * Id.t) list * ((Id.t -> EConstr.constr) -> EConstr.constr -> constr)) * - - (* 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 *) - constr * types + +(** Coq's Program mode support. This mode extends declarations of + constants and fixpoints with [Program Definition] and [Program + Fixpoint] to support incremental construction of terms using + delayed proofs, called "obligations" + + The mode also provides facilities for managing and auto-solving + sets of obligations. + + The basic code flow of programs/obligations is as follows: + + - [add_definition] / [add_mutual_definitions] are called from the + respective [Program] vernacular command interpretation; at this + point the only extra work we do is to prepare the new definition + [d] using [RetrieveObl], which consists in turning unsolved evars + into obligations. [d] is not sent to the kernel yet, as it is not + complete and cannot be typchecked, but saved in a special + data-structure. Auto-solving of obligations is tried at this stage + (see below) + + - [next_obligation] will retrieve the next obligation + ([RetrieveObl] sorts them by topological order) and will try to + solve it. When all obligations are solved, the original constant + [d] is grounded and sent to the kernel for addition to the global + environment. Auto-solving of obligations is also triggered on + obligation completion. + +{2} Solving of obligations: Solved obligations are stored as regular + global declarations in the global environment, usually with name + [constant_obligation_number] where [constant] is the original + [constant] and [number] is the corresponding (internal) number. + + Solving an obligation can trigger a bit of a complex cascaded + callback path; closing an obligation can indeed allow all other + obligations to be closed, which in turn may trigged the declaration + of the original constant. Care must be taken, as this can modify + [Global.env] in arbitrarily ways. Current code takes some care to + refresh the [env] in the proper boundaries, but the invariants + remain delicate. + +{2} Saving of obligations: as open obligations use the regular proof + mode, a `Qed` will call `Lemmas.save_lemma` first. For this reason + obligations code is split in two: this file, [Obligations], taking + care of the top-level vernac commands, and [DeclareObl], which is + called by `Lemmas` to close an obligation proof and eventually to + declare the top-level [Program]ed constant. + + There is little obligations-specific code in [DeclareObl], so + eventually that file should be integrated in the regular [Declare] + path, as it gains better support for "dependent_proofs". + + *) val default_tactic : unit Proofview.tactic ref -val add_definition - : name:Names.Id.t - -> ?term:constr -> types - -> UState.t - -> ?univdecl:UState.universe_decl (* Universe binders and constraints *) - -> ?implicits:Impargs.manual_implicits +(** Start a [Program Definition c] proof. [uctx] [udecl] [impargs] + [kind] [scope] [poly] etc... come from the interpretation of the + vernacular; `obligation_info` was generated by [RetrieveObl] It + will return whether all the obligations were solved; if so, it will + also register [c] with the kernel. *) +val add_definition : + name:Names.Id.t + -> ?term:constr + -> types + -> uctx:UState.t + -> ?udecl:UState.universe_decl (** Universe binders and constraints *) + -> ?impargs:Impargs.manual_implicits -> poly:bool -> ?scope:DeclareDef.locality -> ?kind:Decls.definition_object_kind @@ -61,51 +83,56 @@ val add_definition -> ?reduce:(constr -> constr) -> ?hook:DeclareDef.Hook.t -> ?opaque:bool - -> obligation_info + -> RetrieveObl.obligation_info -> DeclareObl.progress -val add_mutual_definitions - : (Names.Id.t * constr * types * Impargs.manual_implicits * obligation_info) list - -> UState.t - -> ?univdecl:UState.universe_decl - (** Universe binders and constraints *) +(* XXX: unify with MutualEntry *) + +(** Start a [Program Fixpoint] declaration, similar to the above, + except it takes a list now. *) +val add_mutual_definitions : + (DeclareDef.Recthm.t * Constr.t * RetrieveObl.obligation_info) list + -> uctx:UState.t + -> ?udecl:UState.universe_decl (** Universe binders and constraints *) -> ?tactic:unit Proofview.tactic -> poly:bool -> ?scope:DeclareDef.locality -> ?kind:Decls.definition_object_kind -> ?reduce:(constr -> constr) - -> ?hook:DeclareDef.Hook.t -> ?opaque:bool + -> ?hook:DeclareDef.Hook.t + -> ?opaque:bool -> Vernacexpr.decl_notation list - -> DeclareObl.fixpoint_kind -> unit + -> DeclareObl.fixpoint_kind + -> unit -val obligation - : int * Names.Id.t option * Constrexpr.constr_expr option +(** Implementation of the [Obligation] command *) +val obligation : + int * Names.Id.t option * Constrexpr.constr_expr option -> Genarg.glob_generic_argument option -> Lemmas.t -val next_obligation - : Names.Id.t option - -> Genarg.glob_generic_argument option - -> Lemmas.t +(** Implementation of the [Next Obligation] command *) +val next_obligation : + Names.Id.t option -> Genarg.glob_generic_argument option -> Lemmas.t -val solve_obligations : Names.Id.t option -> unit Proofview.tactic option - -> DeclareObl.progress -(* Number of remaining obligations to be solved for this program *) +(** Implementation of the [Solve Obligation] command *) +val solve_obligations : + Names.Id.t option -> unit Proofview.tactic option -> DeclareObl.progress val solve_all_obligations : unit Proofview.tactic option -> unit -val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit +(** Number of remaining obligations to be solved for this program *) +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 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 -> Pp.t - val admit_obligations : Names.Id.t option -> unit exception NoObligations of Names.Id.t option val explain_no_obligations : Names.Id.t option -> Pp.t - val check_program_libraries : unit -> unit diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 84ae04e4cc..054b60853f 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -142,7 +142,7 @@ open Pputils | SearchOutside [] -> mt() | SearchOutside l -> spc() ++ keyword "outside" ++ spc() ++ prlist_with_sep sep pr_module l - let pr_search_about (b,c) = + let pr_search (b,c) = (if b then str "-" else mt()) ++ match c with | SearchSubPattern p -> @@ -158,10 +158,8 @@ open Pputils | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b - | SearchAbout sl -> - keyword "SearchAbout" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b | Search sl -> - keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b + keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search sl ++ pr_in_out_modules b let pr_option_ref_value = function | QualidRefValue id -> pr_qualid id @@ -804,7 +802,7 @@ let string_of_definition_object_kind = let open Decls in function let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in return (hov 2 (pr_assumption_token (n > 1) discharge kind ++ pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions)) - | VernacInductive (cum, p,f,l) -> + | VernacInductive (f,l) -> let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ @@ -830,24 +828,14 @@ let string_of_definition_object_kind = let open Decls in function str" :=") ++ pr_constructor_list lc ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn in - let key = - let kind = - match f with Record -> "Record" | Structure -> "Structure" - | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" - | Class _ -> "Class" | Variant -> "Variant" - in - if p then - let cm = - match cum with - | Some VernacCumulative -> "Cumulative" - | Some VernacNonCumulative -> "NonCumulative" - | None -> "" - in - cm ^ " " ^ kind - else kind + let kind = + match f with + | Record -> "Record" | Structure -> "Structure" + | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" + | Class _ -> "Class" | Variant -> "Variant" in return ( - hov 1 (pr_oneind key (List.hd l)) ++ + hov 1 (pr_oneind kind (List.hd l)) ++ (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) ) diff --git a/vernac/ppvernac.mli b/vernac/ppvernac.mli index 9ade5afb87..9339803948 100644 --- a/vernac/ppvernac.mli +++ b/vernac/ppvernac.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index cdd93db884..a7170c8e18 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -83,6 +83,8 @@ let print_ref reduce ref udecl = let ctx,ccl = Reductionops.splay_prod_assum env sigma typ in EConstr.it_mkProd_or_LetIn ccl ctx else typ in + let impargs = select_stronger_impargs (implicits_of_global ref) in + let impargs = List.map binding_kind_of_status impargs in let variance = let open GlobRef in match ref with | VarRef _ | ConstRef _ -> None | IndRef (ind,_) | ConstructRef ((ind,_),_) -> @@ -95,7 +97,7 @@ let print_ref reduce ref udecl = else mt () in let priv = None in (* We deliberately don't print private univs in About. *) - hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ + hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma ~impargs typ ++ Printer.pr_abstract_universe_ctx sigma ?variance univs ?priv) (********************************) diff --git a/vernac/prettyp.mli b/vernac/prettyp.mli index ac41f30c5d..19a4958350 100644 --- a/vernac/prettyp.mli +++ b/vernac/prettyp.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index b329463cb0..2130a398e9 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/proof_using.mli b/vernac/proof_using.mli index a0567eef47..dfc233e8fa 100644 --- a/vernac/proof_using.mli +++ b/vernac/proof_using.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index 2425f3d6c1..f4cb1adfe8 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -51,14 +51,13 @@ module Vernac_ = let noedit_mode = gec_vernac "noedit_command" let () = - let open Extend in let act_vernac v loc = Some v in let act_eoi _ loc = None in let rule = [ - Rule (Next (Stop, Atoken Tok.PEOI), act_eoi); - Rule (Next (Stop, Aentry vernac_control), act_vernac); + Pcoq.(Production.make (Rule.next Rule.stop (Symbol.token Tok.PEOI)) act_eoi); + Pcoq.(Production.make (Rule.next Rule.stop (Symbol.nterm vernac_control)) act_vernac); ] in - Pcoq.grammar_extend main_entry (None, [None, None, rule]) + Pcoq.(grammar_extend main_entry {pos=None; data=[None, None, rule]}) let select_tactic_entry spec = match spec with diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 3bd252ecef..4de12f5e3b 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/recLemmas.ml b/vernac/recLemmas.ml index e6d428968c..eb0e1fb795 100644 --- a/vernac/recLemmas.ml +++ b/vernac/recLemmas.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * 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) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/recLemmas.mli b/vernac/recLemmas.mli index dfb5e4a644..1a697c1e88 100644 --- a/vernac/recLemmas.mli +++ b/vernac/recLemmas.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * 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) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/record.ml b/vernac/record.ml index 065641989d..d974ead942 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -613,7 +613,7 @@ let add_constant_class env sigma cst = } in Classes.add_class env sigma tc; - set_typeclass_transparency (EvalConstRef cst) false false + Classes.set_typeclass_transparency (EvalConstRef cst) false false let add_inductive_class env sigma ind = let mind, oneind = Inductive.lookup_mind_specif env ind in diff --git a/vernac/record.mli b/vernac/record.mli index 571fd9536e..e890f80150 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/retrieveObl.ml b/vernac/retrieveObl.ml new file mode 100644 index 0000000000..c529972b8d --- /dev/null +++ b/vernac/retrieveObl.ml @@ -0,0 +1,296 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +open Names + +(** + - 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". +*) + +let check_evars env evm = + Evar.Map.iter + (fun key evi -> + if Evd.is_obligation_evar evm key then () + else + let loc, k = Evd.evar_source key evm in + Pretype_errors.error_unsolvable_implicit ?loc env evm key None) + (Evd.undefined_map evm) + +type obligation_info = + ( Names.Id.t + * Constr.types + * Evar_kinds.t Loc.located + * (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t + * unit Proofview.tactic option ) + array + +type oblinfo = + { ev_name : int * Id.t + ; ev_hyps : EConstr.named_context + ; ev_status : bool * Evar_kinds.obligation_definition_status + ; ev_chop : int option + ; ev_src : Evar_kinds.t Loc.located + ; ev_typ : Constr.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 succfix (depth, fixrels) = (succ depth, List.map succ fixrels) + +let subst_evar_constr evm evs n idf t = + let seen = ref Int.Set.empty in + let transparent = ref Id.Set.empty in + let evar_info id = CList.assoc_f Evar.equal id evs in + let rec substrec (depth, fixrels) c = + match EConstr.kind evm c with + | Constr.Evar (k, args) -> + let {ev_name = id, idstr; ev_hyps = hyps; ev_chop = chop} = + try evar_info k + with Not_found -> + CErrors.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 = CList.chop n (List.rev (Array.to_list args)) in + List.rev r + in + let args = + let rec aux hyps args acc = + let open Context.Named.Declaration in + 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 EConstr.kind evm x with + | Constr.Rel n -> Int.List.mem n fixrels + | _ -> false) + args + then transparent := Id.Set.add idstr !transparent; + EConstr.mkApp (idf idstr, Array.of_list args) + | Constr.Fix _ -> + EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c + | _ -> EConstr.map_with_binders evm succfix substrec (depth, fixrels) c + in + let t' = substrec (0, []) t in + (EConstr.to_constr evm 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 Constr.kind c with + | Constr.Var v -> ( + try Constr.mkRel (depth + var_index v) with Not_found -> c ) + | _ -> Constr.map_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 evm evs hyps concl = + let open Context.Named.Declaration in + let rec aux acc n = function + | decl :: tl -> ( + let t', s, trans = + subst_evar_constr evm evs n EConstr.mkVar + (Context.Named.Declaration.get_type decl) + in + let t'' = subst_vars acc 0 t' in + let rest, s', trans' = + aux (Context.Named.Declaration.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 evm evs n EConstr.mkVar c in + let c' = subst_vars acc 0 c' in + ( Term.mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest + , Int.Set.union s'' s' + , Id.Set.union trans'' trans' ) + | LocalAssum (id, _) -> + (Term.mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') ) + | [] -> + let t', s, trans = subst_evar_constr evm evs n EConstr.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 + CList.firstn (len - n) ctx + +let rec chop_product n t = + let pop t = Vars.lift (-1) t in + if Int.equal n 0 then Some t + else + match Constr.kind t with + | Constr.Prod (_, _, b) -> + if Vars.noccurn 1 b then chop_product (pred n) (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' = Evd.evars_of_filtered_evar_info evm evi in + if Evar.Set.mem oev deps' then + invalid_arg + ( "Ill-formed evar map: cycle detected for evar " + ^ Pp.string_of_ppcmds @@ Evar.print 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 [] + +let retrieve_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 evm l hyps ev.Evd.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 = Evd.evar_source id evm in + let status = + match k with + | Evar_kinds.QuestionMark {Evar_kinds.qm_obligation = 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 evm evts 0 EConstr.mkVar t + in + let ty, _, _ = subst_evar_constr evm evts 0 EConstr.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 = Util.pi1 (subst_evar_constr evm evts 0 f c) in + (Array.of_list (List.rev evars), (evnames, evmap), t', ty) diff --git a/vernac/retrieveObl.mli b/vernac/retrieveObl.mli new file mode 100644 index 0000000000..c9c45bd889 --- /dev/null +++ b/vernac/retrieveObl.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +val check_evars : Environ.env -> Evd.evar_map -> unit + +type obligation_info = + ( Names.Id.t + * Constr.types + * Evar_kinds.t Loc.located + * (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t + * unit Proofview.tactic option ) + array +(** ident, type, location of the original evar, (opaque or + transparent, expand or define), dependencies as indexes into the + array, tactic to solve it *) + +val retrieve_obligations : + Environ.env + -> Names.Id.t + -> Evd.evar_map + -> int + -> ?status:Evar_kinds.obligation_definition_status + -> EConstr.t + -> EConstr.types + -> obligation_info + * ( (Evar.t * Names.Id.t) list + * ((Names.Id.t -> EConstr.t) -> EConstr.t -> Constr.t) ) + * Constr.t + * Constr.t +(** [retrieve_obligations env id sigma fs ?status body type] returns + [obls, (evnames, evmap), nbody, ntype] a list of obligations built + from evars in [body, type]. + + [fs] is the number of function prototypes to try to clear from + evars contexts. [evnames, evmap) is the list of names / + substitution functions used to program with holes. This is not used + in Coq, but in the equations plugin; [evnames] is actually + redundant with the information contained in [obls] *) diff --git a/vernac/search.ml b/vernac/search.ml index b8825c3b29..68a30b4231 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -23,8 +23,8 @@ module NamedDecl = Context.Named.Declaration type filter_function = GlobRef.t -> env -> constr -> bool type display_function = GlobRef.t -> env -> constr -> unit -(* This option restricts the output of [SearchPattern ...], -[SearchAbout ...], etc. to the names of the symbols matching the +(* This option restricts the output of [SearchPattern ...], 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 through the types of all symbols. *) @@ -226,7 +226,7 @@ let module_filter (mods, outside) ref env typ = let name_of_reference ref = Id.to_string (Nametab.basename_of_global ref) -let search_about_filter query gr env typ = match query with +let search_filter query gr env typ = match query with | GlobSearchSubPattern pat -> Constr_matching.is_matching_appsubterm ~closed:false env (Evd.from_env env) pat (EConstr.of_constr typ) | GlobSearchString s -> @@ -283,14 +283,14 @@ let search_by_head ?pstate gopt pat mods pr_search = in generic_search ?pstate gopt iter -(** SearchAbout *) +(** Search *) -let search_about ?pstate gopt items mods pr_search = +let search ?pstate gopt items mods pr_search = 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 && + (fun (b,i) -> eqb b (search_filter i ref env typ)) items && blacklist_filter ref env typ in let iter ref env typ = diff --git a/vernac/search.mli b/vernac/search.mli index 029e8cf7b9..6dbbff3a8c 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -30,8 +30,7 @@ val blacklist_filter : filter_function 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. *) +val search_filter : glob_search_about_item -> filter_function (** {6 Specialized search functions} @@ -45,7 +44,7 @@ val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> D -> display_function -> unit val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_about : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list +val search : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 509c164af8..2d8734ff7f 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index dc4642dc65..c54e75e8cc 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 6e398d87ca..5a2bdb43d4 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -14,6 +14,7 @@ Proof_using Egramcoq Metasyntax DeclareUniv +RetrieveObl DeclareDef DeclareObl Canonical diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index c78b470e3b..4806c6bb9c 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -473,11 +473,14 @@ let program_inference_hook env sigma ev = let concl = evi.Evd.evar_concl in if not (Evarutil.is_ground_env sigma env && Evarutil.is_ground_term sigma concl) - then raise Exit; - let c, _, ctx = - Pfedit.build_by_tactic ~poly:false env (Evd.evar_universe_context sigma) concl tac - in Evd.set_universe_context sigma ctx, EConstr.of_constr c - with Logic_monad.TacticFailure e when Logic.catchable_exception e -> + then None + else + let c, _, _, ctx = + Pfedit.build_by_tactic ~poly:false env ~uctx:(Evd.evar_universe_context sigma) ~typ:concl tac + in + Some (Evd.set_universe_context sigma ctx, EConstr.of_constr c) + with + | Logic_monad.TacticFailure e when noncritical e -> user_err Pp.(str "The statement obligations could not be resolved \ automatically, write a statement definition first.") @@ -493,17 +496,12 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = let evd = Pretyping.solve_remaining_evars ?hook:inference_hook flags env evd in let ids = List.map Context.Rel.Declaration.get_name ctx in check_name_freshness scope id; - (* XXX: The nf_evar is critical !! *) - evd, (id.CAst.v, - (Evarutil.nf_evar evd (EConstr.it_mkProd_or_LetIn t' ctx), - (ids, imps @ imps')))) + evd, (id.CAst.v, (EConstr.it_mkProd_or_LetIn t' ctx, (ids, imps @ imps')))) evd thms in let recguard,thms,snl = RecLemmas.look_for_possibly_mutual_statements evd thms in let evd = Evd.minimize_universes evd in - (* XXX: This nf_evar is critical too!! We are normalizing twice if - you look at the previous lines... *) let thms = List.map (fun (name, (typ, (args, impargs))) -> - { Lemmas.Recthm.name; typ = EConstr.to_constr evd typ; args; impargs} ) thms in + { DeclareDef.Recthm.name; typ = EConstr.to_constr evd typ; args; impargs} ) thms in let () = let open UState in if not (udecl.univdecl_extensible_instance && udecl.univdecl_extensible_constraints) then @@ -529,8 +527,10 @@ let vernac_definition_hook ~canonical_instance ~local ~poly = let open Decls in Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure dref))) | _ -> None +let default_thm_id = Id.of_string "Unnamed_thm" + let fresh_name_for_anonymous_theorem () = - Namegen.next_global_ident_away Lemmas.default_thm_id Id.Set.empty + Namegen.next_global_ident_away default_thm_id Id.Set.empty let vernac_definition_name lid local = let lid = @@ -567,7 +567,9 @@ let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt let env = Global.env () in let sigma = Evd.from_env env in Some (snd (Hook.get f_interp_redexp env sigma r)) in - ComDefinition.do_definition ~program_mode ~name:name.v + let do_definition = + ComDefinition.(if program_mode then do_definition_program else do_definition) in + do_definition ~name:name.v ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook (* NB: pstate argument to use combinators easily *) @@ -604,17 +606,39 @@ let vernac_assumption ~atts discharge kind l nl = let is_polymorphic_inductive_cumulativity = declare_bool_option_and_ref ~depr:false ~value:false - ~key:["Polymorphic"; "Inductive"; "Cumulativity"] - -let should_treat_as_cumulative cum poly = - match cum with - | Some VernacCumulative -> - if poly then true - else user_err Pp.(str "The Cumulative prefix can only be used in a polymorphic context.") - | Some VernacNonCumulative -> - if poly then false - else user_err Pp.(str "The NonCumulative prefix can only be used in a polymorphic context.") - | None -> poly && is_polymorphic_inductive_cumulativity () + ~key:["Polymorphic";"Inductive";"Cumulativity"] + +let polymorphic_cumulative = + let error_poly_context () = + user_err + Pp.(str "The cumulative and noncumulative attributes can only be used in a polymorphic context."); + in + let open Attributes in + let open Notations in + qualify_attribute "universes" + (bool_attribute ~name:"Polymorphism" ~on:"polymorphic" ~off:"monomorphic" + ++ bool_attribute ~name:"Cumulativity" ~on:"cumulative" ~off:"noncumulative") + >>= function + | Some poly, Some cum -> + (* Case of Polymorphic|Monomorphic Cumulative|NonCumulative Inductive + and #[ universes(polymorphic|monomorphic,cumulative|noncumulative) ] Inductive *) + if poly then return (true, cum) + else error_poly_context () + | Some poly, None -> + (* Case of Polymorphic|Monomorphic Inductive + and #[ universes(polymorphic|monomorphic) ] Inductive *) + if poly then return (true, is_polymorphic_inductive_cumulativity ()) + else return (false, false) + | None, Some cum -> + (* Case of Cumulative|NonCumulative Inductive *) + if is_universe_polymorphism () then return (true, cum) + else error_poly_context () + | None, None -> + (* Case of Inductive *) + if is_universe_polymorphism () then + return (true, is_polymorphic_inductive_cumulativity ()) + else + return (false, false) let get_uniform_inductive_parameters = Goptions.declare_bool_option_and_ref @@ -627,8 +651,7 @@ let should_treat_as_uniform () = then ComInductive.UniformParameters else ComInductive.NonUniformParameters -let vernac_record ~template udecl cum k poly finite records = - let cumulative = should_treat_as_cumulative cum poly in +let vernac_record ~template udecl ~cumulative k ~poly finite records = let map ((coe, id), binders, sort, nameopt, cfs) = let const = match nameopt with | None -> Nameops.add_prefix "Build_" id.v @@ -668,12 +691,21 @@ let finite_of_kind = let open Declarations in function | CoInductive -> CoFinite | Variant | Record | Structure | Class _ -> BiFinite -(** 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 ~atts cum lo kind indl = - let template, poly = Attributes.(parse Notations.(template ++ polymorphic) atts) in +let private_ind = + let open Attributes in + let open Notations in + attribute_of_list + [ "matching" + , single_key_parser ~name:"Private (matching) inductive type" ~key:"matching" () + ] + |> qualify_attribute "private" + >>= function + | Some () -> return true + | None -> return false + +let vernac_inductive ~atts kind indl = + let (template, (poly, cumulative)), private_ind = Attributes.( + parse Notations.(template ++ polymorphic_cumulative ++ private_ind) atts) in let open Pp in let udecl, indl = extract_inductive_udecl indl in if Dumpglob.dump () then @@ -710,7 +742,7 @@ let vernac_inductive ~atts cum lo kind indl = let coe' = if coe then Some true else None in let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce), { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] ; rf_canonical = true } in - vernac_record ~template udecl cum (Class true) poly finite [id, bl, c, None, [f]] + vernac_record ~template udecl ~cumulative (Class true) ~poly finite [id, bl, c, None, [f]] else if List.for_all is_record indl then (* Mutual record case *) let () = match kind with @@ -735,7 +767,7 @@ let vernac_inductive ~atts cum lo kind indl = in let kind = match kind with Class _ -> Class false | _ -> kind in let recordl = List.map unpack indl in - vernac_record ~template udecl cum kind poly finite recordl + vernac_record ~template udecl ~cumulative kind ~poly finite recordl else if List.for_all is_constructor indl then (* Mutual inductive case *) let () = match kind with @@ -758,9 +790,8 @@ let vernac_inductive ~atts cum lo kind indl = | RecordDecl _ -> assert false (* ruled out above *) in let indl = List.map unpack indl in - let cumulative = should_treat_as_cumulative cum poly in let uniform = should_treat_as_uniform () in - ComInductive.do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind:lo ~uniform finite + ComInductive.do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uniform finite else user_err (str "Mixed record-inductive definitions are not allowed") @@ -956,7 +987,7 @@ let vernac_begin_section ~poly ({v=id} as lid) = to its current value ie noop. *) set_bool_option_value_gen ~locality:OptLocal ["Universe"; "Polymorphism"] poly -let vernac_end_section {CAst.loc} = +let vernac_end_section {CAst.loc; v} = Dumpglob.dump_reference ?loc (DirPath.to_string (Lib.current_dirpath true)) "<>" "sec"; Lib.close_section () @@ -966,6 +997,7 @@ let vernac_name_sec_hyp {v=id} set = Proof_using.name_set id set (* Dispatcher of the "End" command *) let vernac_end_segment ({v=id} as lid) = + DeclareObl.check_can_close lid.v; match Lib.find_opening_node id with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid @@ -1178,9 +1210,19 @@ let vernac_hints ~atts dbnames h = (warn_implicit_core_hint_db (); ["core"]) else dbnames in - let local, poly = Attributes.(parse Notations.(locality ++ polymorphic) atts) in - let local = enforce_module_locality local in - Hints.add_hints ~local dbnames (Hints.interp_hints ~poly h) + let locality, poly = Attributes.(parse Notations.(option_locality ++ polymorphic) atts) in + let () = match locality with + | OptGlobal -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the global attribute in sections."); + | OptExport -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the export attribute in sections."); + | OptDefault | OptLocal -> () + in + Hints.add_hints ~locality dbnames (Hints.interp_hints ~poly h) let vernac_syntactic_definition ~atts lid x only_parsing = let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in @@ -1454,40 +1496,29 @@ let vernac_set_opacity ~local (v,l) = let l = List.map glob_ref l in Redexpr.set_strategy local [v,l] -let get_option_locality export local = - if export then - if Option.is_empty local then OptExport - else user_err Pp.(str "Locality modifiers forbidden with Export") - else match local with - | Some true -> OptLocal - | Some false -> OptGlobal - | None -> OptDefault - -let vernac_set_option0 ~local export key opt = - let locality = get_option_locality export local in +let vernac_set_option0 ~locality key opt = match opt with | OptionUnset -> unset_option_value_gen ~locality key | OptionSetString s -> set_string_option_value_gen ~locality key s | OptionSetInt n -> set_int_option_value_gen ~locality key (Some n) | OptionSetTrue -> set_bool_option_value_gen ~locality key true -let vernac_set_append_option ~local export key s = - let locality = get_option_locality export local in +let vernac_set_append_option ~locality key s = set_string_option_append_value_gen ~locality key s -let vernac_set_option ~local export table v = match v with +let vernac_set_option ~locality table v = match v with | OptionSetString s -> (* We make a special case for warnings because appending is their natural semantics *) if CString.List.equal table ["Warnings"] then - vernac_set_append_option ~local export table s + vernac_set_append_option ~locality table s else let (last, prefix) = List.sep_last table in if String.equal last "Append" && not (List.is_empty prefix) then - vernac_set_append_option ~local export prefix s + vernac_set_append_option ~locality prefix s else - vernac_set_option0 ~local export table v -| _ -> vernac_set_option0 ~local export table v + vernac_set_option0 ~locality table v +| _ -> vernac_set_option0 ~locality table v let vernac_add_option key lv = let f = function @@ -1595,12 +1626,11 @@ let get_nth_goal ~pstate n = let gl = {Evd.it=List.nth goals (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 ~pstate ?loc ref_or_by_not udecl glopt = + let exception NoHyp in let open Context.Named.Declaration in try (* Fallback early to globals *) @@ -1747,10 +1777,6 @@ let () = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let warn_deprecated_search_about = - CWarnings.create ~name:"deprecated-search-about" ~category:"deprecated" - (fun () -> strbrk "The SearchAbout command is deprecated. Please use Search instead.") - let vernac_search ~pstate ~atts s gopt r = let gopt = query_command_selector gopt in let r = interp_search_restriction r in @@ -1768,25 +1794,25 @@ let vernac_search ~pstate ~atts s gopt r = let pp = if !search_output_name_only then pr else begin - let pc = pr_lconstr_env env Evd.(from_env env) c in + let open Impargs in + let impargs = select_stronger_impargs (implicits_of_global ref) in + let impargs = List.map binding_kind_of_status impargs in + let pc = pr_ltype_env env Evd.(from_env env) ~impargs c in hov 2 (pr ++ str":" ++ spc () ++ pc) end in Feedback.msg_notice pp in - match s with + (match s with | SearchPattern c -> (Search.search_pattern ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchRewrite c -> (Search.search_rewrite ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchHead c -> (Search.search_by_head ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search - | SearchAbout sl -> - warn_deprecated_search_about (); - (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> - Search.prioritize_search) pr_search | Search sl -> - (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> - Search.prioritize_search) pr_search + (Search.search ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> + Search.prioritize_search) pr_search); + Feedback.msg_notice (str "(use \"About\" for full details on implicit arguments)") let vernac_locate ~pstate = let open Constrexpr in function | LocateAny {v=AN qid} -> Prettyp.print_located_qualid qid @@ -1994,8 +2020,8 @@ let translate_vernac ~atts v = let open Vernacextend in match v with vernac_declare_module_type lid bl mtys mtyo) | VernacAssumption ((discharge,kind),nl,l) -> VtDefault(fun () -> with_def_attributes ~atts vernac_assumption discharge kind l nl) - | VernacInductive (cum, priv, finite, l) -> - VtDefault(fun () -> vernac_inductive ~atts cum priv finite l) + | VernacInductive (finite, l) -> + VtDefault(fun () -> vernac_inductive ~atts finite l) | VernacFixpoint (discharge, l) -> let opens = List.exists (fun { body_def } -> Option.is_empty body_def) l in if opens then @@ -2150,9 +2176,10 @@ let translate_vernac ~atts v = let open Vernacextend in match v with VtDefault(fun () -> with_locality ~atts vernac_set_opacity qidl) | VernacSetStrategy l -> VtDefault(fun () -> with_locality ~atts vernac_set_strategy l) - | VernacSetOption (export, key,v) -> + | VernacSetOption (export,key,v) -> + let atts = if export then ("export", VernacFlagEmpty) :: atts else atts in VtDefault(fun () -> - vernac_set_option ~local:(only_locality atts) export key v) + vernac_set_option ~locality:(parse option_locality atts) key v) | VernacRemoveOption (key,v) -> VtDefault(fun () -> unsupported_attributes atts; diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 6368ebeed8..f5cf9702cd 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 7169ea834a..d6e7a3947a 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -69,7 +69,6 @@ type searchable = | SearchPattern of constr_pattern_expr | SearchRewrite of constr_pattern_expr | SearchHead of constr_pattern_expr - | SearchAbout of (bool * search_about_item) list | Search of (bool * search_about_item) list type locatable = @@ -250,10 +249,6 @@ type register_kind = type module_ast_inl = module_ast * Declaremods.inline type module_binder = bool option * lident list * module_ast_inl -(** [Some b] if locally enabled/disabled according to [b], [None] if - we should use the global flag. *) -type vernac_cumulative = VernacCumulative | VernacNonCumulative - (** {6 The type of vernacular expressions} *) type vernac_one_argument_status = { @@ -312,7 +307,7 @@ type nonrec vernac_expr = | VernacExactProof of constr_expr | VernacAssumption of (discharge * Decls.assumption_object_kind) * Declaremods.inline * (ident_decl list * constr_expr) with_coercion list - | VernacInductive of vernac_cumulative option * bool (* private *) * inductive_kind * (inductive_expr * decl_notation list) list + | VernacInductive of inductive_kind * (inductive_expr * decl_notation list) list | VernacFixpoint of discharge * fixpoint_expr list | VernacCoFixpoint of discharge * cofixpoint_expr list | VernacScheme of (lident option * scheme) list @@ -403,7 +398,7 @@ type nonrec vernac_expr = | VernacSetOpacity of (Conv_oracle.level * qualid or_by_notation list) | VernacSetStrategy of (Conv_oracle.level * qualid or_by_notation list) list - | VernacSetOption of export_flag * Goptions.option_name * option_setting + | VernacSetOption of bool (* Export modifier? *) * Goptions.option_name * option_setting | VernacAddOption of Goptions.option_name * option_ref_value list | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 5d38ea32be..1920c276af 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -166,15 +166,15 @@ let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args -> vernac_c | Some Refl -> untype_command ty (f v) args end -let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, Extend.norec, a) Extend.symbol = +let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, Gramlib.Grammar.norec, a) Pcoq.Symbol.t = let open Extend in function -| TUlist1 l -> Alist1 (untype_user_symbol l) -| TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s)) -| TUlist0 l -> Alist0 (untype_user_symbol l) -| TUlist0sep (l, s) -> Alist0sep (untype_user_symbol l, Atoken (CLexer.terminal s)) -| TUopt o -> Aopt (untype_user_symbol o) -| TUentry a -> Aentry (Pcoq.genarg_grammar (Genarg.ExtraArg a)) -| TUentryl (a, i) -> Aentryl (Pcoq.genarg_grammar (Genarg.ExtraArg a), string_of_int i) + | TUlist1 l -> Pcoq.Symbol.list1 (untype_user_symbol l) + | TUlist1sep (l, s) -> Pcoq.Symbol.list1sep (untype_user_symbol l) (Pcoq.Symbol.token (CLexer.terminal s)) false + | TUlist0 l -> Pcoq.Symbol.list0 (untype_user_symbol l) + | TUlist0sep (l, s) -> Pcoq.Symbol.list0sep (untype_user_symbol l) (Pcoq.Symbol.token (CLexer.terminal s)) false + | TUopt o -> Pcoq.Symbol.opt (untype_user_symbol o) + | TUentry a -> Pcoq.Symbol.nterm (Pcoq.genarg_grammar (Genarg.ExtraArg a)) + | TUentryl (a, i) -> Pcoq.Symbol.nterml (Pcoq.genarg_grammar (Genarg.ExtraArg a)) (string_of_int i) let rec untype_grammar : type r s. (r, s) ty_sig -> 'a Egramml.grammar_prod_item list = function | TyNil -> [] @@ -229,7 +229,7 @@ let vernac_extend ~command ?classifier ?entry ext = type 'a argument_rule = | Arg_alias of 'a Pcoq.Entry.t -| Arg_rules of 'a Extend.production_rule list +| Arg_rules of 'a Pcoq.Production.t list type 'a vernac_argument = { arg_printer : Environ.env -> Evd.evar_map -> 'a -> Pp.t; @@ -244,7 +244,7 @@ let vernac_argument_extend ~name arg = e | Arg_rules rules -> let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in - let () = Pcoq.grammar_extend e (None, [(None, None, rules)]) in + let () = Pcoq.grammar_extend e {Pcoq.pos=None; data=[(None, None, rules)]} in e in let pr = arg.arg_printer in diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 3df74e5f2c..0d0ebc1086 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -111,7 +111,7 @@ type 'a argument_rule = | Arg_alias of 'a Pcoq.Entry.t (** This is used because CAMLP5 parser can be dumb about rule factorization, which sometimes requires two entries to be the same. *) -| Arg_rules of 'a Extend.production_rule list +| Arg_rules of 'a Pcoq.Production.t list (** There is a discrepancy here as we use directly extension rules and thus entries instead of ty_user_symbol and thus arguments as roots. *) diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 8083098022..15a19c06c2 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index 16849686da..9f5bfb46ee 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index 903a28e953..a632d860a7 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/vernacprop.mli b/vernac/vernacprop.mli index 320878e401..352c81b8b4 100644 --- a/vernac/vernacprop.mli +++ b/vernac/vernacprop.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 280343f315..6846826bfa 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index b4322eb09a..7607f8373a 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -1,7 +1,7 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) |