diff options
Diffstat (limited to 'tactics')
| -rw-r--r-- | tactics/declare.ml | 57 | ||||
| -rw-r--r-- | tactics/declare.mli | 4 | ||||
| -rw-r--r-- | tactics/pfedit.ml | 5 | ||||
| -rw-r--r-- | tactics/proof_global.ml | 4 | ||||
| -rw-r--r-- | tactics/proof_global.mli | 2 |
5 files changed, 24 insertions, 48 deletions
diff --git a/tactics/declare.ml b/tactics/declare.ml index e418240d3a..61321cd605 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -52,11 +52,7 @@ let name_instance inst = let declare_universe_context ~poly ctx = if poly then - (* FIXME: some upper layers declare universes several times, we hack around - by checking whether the universes already exist. *) - let (univs, cstr) = ctx in - let univs = Univ.LSet.filter (fun u -> not (Lib.is_polymorphic_univ u)) univs in - let uctx = Univ.ContextSet.to_context (univs, cstr) in + let uctx = Univ.ContextSet.to_context ctx in let nas = name_instance (Univ.UContext.instance uctx) in Global.push_section_context (nas, uctx) else @@ -72,7 +68,7 @@ type constant_obj = { type 'a proof_entry = { proof_entry_body : 'a Entries.const_entry_body; (* List of section variables *) - proof_entry_secctx : Constr.named_context option; + proof_entry_secctx : Id.Set.t option; (* State id on which the completion of type checking is reported *) proof_entry_feedback : Stateid.t option; proof_entry_type : Constr.types option; @@ -228,7 +224,7 @@ let cast_opaque_proof_entry e = ids_typ, vars in let () = if Aux_file.recording () then record_aux env hyp_typ hyp_def in - keep_hyps env (Id.Set.union hyp_typ hyp_def) + Environ.really_needed env (Id.Set.union hyp_typ hyp_def) | Some hyps -> hyps in { @@ -253,14 +249,13 @@ let is_unsafe_typing_flags () = let define_constant ~side_effect ~name cd = (* Logically define the constant and its subproofs, no libobject tampering *) - let in_section = Lib.sections_are_opened () in let export, decl, unsafe = match cd with | DefinitionEntry de -> (* We deal with side effects *) if not de.proof_entry_opaque then (* This globally defines the side-effects in the environment. *) let body, eff = Future.force de.proof_entry_body in - let body, export = Global.export_private_constants ~in_section (body, eff.Evd.seff_private) in + let body, export = Global.export_private_constants (body, eff.Evd.seff_private) in let export = get_roles export eff in let de = { de with proof_entry_body = Future.from_val (body, ()) } in let cd = Entries.DefinitionEntry (cast_proof_entry de) in @@ -276,7 +271,7 @@ let define_constant ~side_effect ~name cd = | PrimitiveEntry e -> [], ConstantEntry (PureEntry, Entries.PrimitiveEntry e), false in - let kn, eff = Global.add_constant ~side_effect ~in_section name decl in + let kn, eff = Global.add_constant ~side_effect name decl in if unsafe || is_unsafe_typing_flags() then feedback_axiom(); kn, eff, export @@ -302,7 +297,7 @@ let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind (** Declaration of section variables and local definitions *) type variable_declaration = | SectionLocalDef of Evd.side_effects proof_entry - | SectionLocalAssum of { typ:Constr.types; univs:Univ.ContextSet.t; poly:bool; impl:Glob_term.binding_kind } + | SectionLocalAssum of { typ:Constr.types; impl:Glob_term.binding_kind; } (* This object is only for things which iterate over objects to find variables (only Prettyp.print_context AFAICT) *) @@ -315,16 +310,15 @@ let declare_variable ~name ~kind d = if Decls.variable_exists name then raise (AlreadyDeclared (None, name)); - let impl,opaque,poly = match d with (* Fails if not well-typed *) - | SectionLocalAssum {typ;univs;poly;impl} -> - let () = declare_universe_context ~poly univs in + let impl,opaque = match d with (* Fails if not well-typed *) + | SectionLocalAssum {typ;impl} -> let () = Global.push_named_assum (name,typ) in - impl, true, poly + impl, true | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) let (body, eff) = Future.force de.proof_entry_body in - let ((body, uctx), export) = Global.export_private_constants ~in_section:true (body, eff.Evd.seff_private) in + let ((body, uctx), export) = Global.export_private_constants (body, eff.Evd.seff_private) in let eff = get_roles export eff in let () = List.iter register_side_effect eff in let poly, univs = match de.proof_entry_universes with @@ -342,12 +336,11 @@ let declare_variable ~name ~kind d = secdef_type = de.proof_entry_type; } in let () = Global.push_named_def (name, se) in - Glob_term.Explicit, de.proof_entry_opaque, - poly + Glob_term.Explicit, de.proof_entry_opaque in Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); Decls.(add_variable_data name {opaque;kind}); - add_anonymous_leaf (inVariable ()); + ignore(add_leaf name (inVariable ()) : Libobject.object_name); Impargs.declare_var_implicits ~impl name; Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) @@ -591,7 +584,7 @@ let declare_univ_binders gr pl = Lib.add_anonymous_leaf (input_univ_names (QualifiedUniv l, univs)) let do_universe ~poly l = - let in_section = Lib.sections_are_opened () in + let in_section = Global.sections_are_opened () in let () = if poly && not in_section then CErrors.user_err ~hdr:"Constraint" @@ -608,28 +601,12 @@ let do_universe ~poly l = let do_constraint ~poly l = let open Univ in let u_of_id x = - let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in - Lib.is_polymorphic_univ level, level - in - let in_section = Lib.sections_are_opened () in - let () = - if poly && not in_section then - CErrors.user_err ~hdr:"Constraint" - (str"Cannot declare polymorphic constraints outside sections") - in - let check_poly p p' = - if poly then () - else if p || p' then - CErrors.user_err ~hdr:"Constraint" - (str "Cannot declare a global constraint on " ++ - str "a polymorphic universe, use " - ++ str "Polymorphic Constraint instead") + Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in let constraints = List.fold_left (fun acc (l, d, r) -> - let p, lu = u_of_id l and p', ru = u_of_id r in - check_poly p p'; - Constraint.add (lu, d, ru) acc) - Constraint.empty l + let lu = u_of_id l and ru = u_of_id r in + Constraint.add (lu, d, ru) acc) + Constraint.empty l in let uctx = ContextSet.add_constraints constraints ContextSet.empty in declare_universe_context ~poly uctx diff --git a/tactics/declare.mli b/tactics/declare.mli index 4cb876cecb..f4bfdb1547 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -23,7 +23,7 @@ open Entries type 'a proof_entry = { proof_entry_body : 'a Entries.const_entry_body; (* List of section variables *) - proof_entry_secctx : Constr.named_context option; + proof_entry_secctx : Id.Set.t option; (* State id on which the completion of type checking is reported *) proof_entry_feedback : Stateid.t option; proof_entry_type : Constr.types option; @@ -36,7 +36,7 @@ type 'a proof_entry = { type variable_declaration = | SectionLocalDef of Evd.side_effects proof_entry - | SectionLocalAssum of { typ:types; univs:Univ.ContextSet.t; poly:bool; impl:Glob_term.binding_kind } + | SectionLocalAssum of { typ:types; impl:Glob_term.binding_kind; } type 'a constant_entry = | DefinitionEntry of 'a proof_entry diff --git a/tactics/pfedit.ml b/tactics/pfedit.ml index 5be7b4fa28..413c6540a3 100644 --- a/tactics/pfedit.ml +++ b/tactics/pfedit.ml @@ -124,8 +124,7 @@ let build_constant_by_tactic ~name ctx sign ~poly typ tac = let { entries; universes } = close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in match entries with | [entry] -> - let univs = UState.demote_seff_univs entry.Declare.proof_entry_universes universes in - entry, status, univs + entry, status, universes | _ -> CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") with reraise -> @@ -141,7 +140,7 @@ let build_by_tactic ?(side_eff=true) env sigma ~poly typ tac = if side_eff then Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) else body in - let univs = UState.merge ~sideff:side_eff ~extend:true Evd.univ_rigid univs ctx in + let univs = UState.merge ~sideff:side_eff Evd.univ_rigid univs ctx in cb, status, univs let refine_by_tactic ~name ~poly env sigma ty tac = diff --git a/tactics/proof_global.ml b/tactics/proof_global.ml index a2929e45cd..b723922642 100644 --- a/tactics/proof_global.ml +++ b/tactics/proof_global.ml @@ -36,7 +36,7 @@ type opacity_flag = Opaque | Transparent type t = { endline_tactic : Genarg.glob_generic_argument option - ; section_vars : Constr.named_context option + ; section_vars : Id.Set.t option ; proof : Proof.t ; udecl: UState.universe_decl (** Initial universe declarations *) @@ -128,7 +128,7 @@ let set_used_variables ps l = if not (Option.is_empty ps.section_vars) then CErrors.user_err Pp.(str "Used section variables can be declared only once"); (* EJGA: This is always empty thus we should modify the type *) - (ctx, []), { ps with section_vars = Some ctx} + (ctx, []), { ps with section_vars = Some (Context.Named.to_vars ctx) } let get_open_goals ps = let Proof.{ goals; stack; shelf } = Proof.data ps.proof in diff --git a/tactics/proof_global.mli b/tactics/proof_global.mli index d15e23c2cc..b9d1b37a11 100644 --- a/tactics/proof_global.mli +++ b/tactics/proof_global.mli @@ -17,7 +17,7 @@ type t (* Should be moved into a proper view *) val get_proof : t -> Proof.t val get_proof_name : t -> Names.Id.t -val get_used_variables : t -> Constr.named_context option +val get_used_variables : t -> Names.Id.Set.t option (** Get the universe declaration associated to the current proof. *) val get_universe_decl : t -> UState.universe_decl |