diff options
author | Matthieu Sozeau <matthieu.sozeau@inria.fr> | 2016-01-23 15:17:29 -0500 |
---|---|---|
committer | Matthieu Sozeau <matthieu.sozeau@inria.fr> | 2016-01-23 15:58:06 -0500 |
commit | 5cbcc8fd761df0779f6202fef935f07cfef8a228 (patch) | |
tree | 886d05ab59b157b812879facc6ef3fa3defc7d20 | |
parent | ccdc62a6b4722c38f2b37cbf21b14e5094255390 (diff) |
Implement support for universe binder lists in Instance and Program Fixpoint/Definition.
-rw-r--r-- | interp/dumpglob.ml | 2 | ||||
-rw-r--r-- | intf/constrexpr.mli | 2 | ||||
-rw-r--r-- | parsing/g_vernac.ml4 | 8 | ||||
-rw-r--r-- | parsing/pcoq.ml4 | 1 | ||||
-rw-r--r-- | parsing/pcoq.mli | 1 | ||||
-rw-r--r-- | printing/ppvernac.ml | 5 | ||||
-rw-r--r-- | tactics/rewrite.ml | 4 | ||||
-rw-r--r-- | toplevel/classes.ml | 29 | ||||
-rw-r--r-- | toplevel/classes.mli | 3 | ||||
-rw-r--r-- | toplevel/command.ml | 29 | ||||
-rw-r--r-- | toplevel/obligations.ml | 26 | ||||
-rw-r--r-- | toplevel/obligations.mli | 2 |
12 files changed, 67 insertions, 45 deletions
diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 0d9d021c6..44a62ef37 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -248,7 +248,7 @@ let dump_def ty loc secpath id = let dump_definition (loc, id) sec s = dump_def s loc (Names.DirPath.to_string (Lib.current_dirpath sec)) (Names.Id.to_string id) -let dump_constraint ((loc, n), _, _) sec ty = +let dump_constraint (((loc, n),_), _, _) sec ty = match n with | Names.Name id -> dump_definition (loc, id) sec ty | Names.Anonymous -> () diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index dcdbd47f6..a53238dfd 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -121,7 +121,7 @@ and constr_notation_substitution = constr_expr list list * (** for recursive notations *) local_binder list list (** for binders subexpressions *) -type typeclass_constraint = Name.t located * binding_kind * constr_expr +type typeclass_constraint = (Name.t located * Id.t located list option) * binding_kind * constr_expr and typeclass_context = typeclass_constraint list diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 839f768b9..f3766a7d7 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -192,7 +192,7 @@ let test_plurial_form_types = function (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - record_field decl_notation rec_definition; + record_field decl_notation rec_definition pidentref; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -783,10 +783,10 @@ GEXTEND Gram | IDENT "transparent" -> Conv_oracle.transparent ] ] ; instance_name: - [ [ name = identref; sup = OPT binders -> - (let (loc,id) = name in (loc, Name id)), + [ [ name = pidentref; sup = OPT binders -> + (let ((loc,id),l) = name in ((loc, Name id),l)), (Option.default [] sup) - | -> (!@loc, Anonymous), [] ] ] + | -> ((!@loc, Anonymous), None), [] ] ] ; reserv_list: [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ] diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 32dbeaa4d..28dc74e81 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -315,6 +315,7 @@ module Prim = let name = Gram.entry_create "Prim.name" let identref = Gram.entry_create "Prim.identref" + let pidentref = Gram.entry_create "Prim.pidentref" let pattern_ident = Gram.entry_create "pattern_ident" let pattern_identref = Gram.entry_create "pattern_identref" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 24b58775a..54e642387 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -163,6 +163,7 @@ module Prim : val ident : Id.t Gram.entry val name : Name.t located Gram.entry val identref : Id.t located Gram.entry + val pidentref : (Id.t located * (Id.t located list) option) Gram.entry val pattern_ident : Id.t Gram.entry val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index d2f59e7b8..38add9d2c 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -925,8 +925,9 @@ module Make hov 1 ( (if abst then keyword "Declare" ++ spc () else mt ()) ++ keyword "Instance" ++ - (match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () | - Anonymous -> mt ()) ++ + (match instid with + | (loc, Name id), l -> spc () ++ pr_plident ((loc, id),l) ++ spc () + | (_, Anonymous), _ -> mt ()) ++ pr_and_type_binders_arg sup ++ str":" ++ spc () ++ pr_constr cl ++ pr_priority pri ++ diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 74bb6d597..83742bfbd 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1703,7 +1703,7 @@ let rec strategy_of_ast = function let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) let declare_an_instance n s args = - ((Loc.ghost,Name n), Explicit, + (((Loc.ghost,Name n),None), Explicit, CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), args)) @@ -1919,7 +1919,7 @@ let add_morphism glob binders m s n = let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = - ((Loc.ghost,Name instance_id), Explicit, + (((Loc.ghost,Name instance_id),None), Explicit, CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), [cHole; s; m])) diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 3a0b5f24f..f73dd5a2e 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -101,19 +101,21 @@ let instance_hook k pri global imps ?hook cst = Typeclasses.declare_instance pri (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant k pri global imps ?hook id poly uctx term termtype = +let declare_instance_constant k pri global imps ?hook id pl poly evm term termtype = let kind = IsDefinition Instance in - let uctx = + let evm = let levels = Univ.LSet.union (Universes.universes_of_constr termtype) (Universes.universes_of_constr term) in - Universes.restrict_universe_context uctx levels + Evd.restrict_universe_context evm levels in + let pl, uctx = Evd.universe_context ?names:pl evm in let entry = - Declare.definition_entry ~types:termtype ~poly ~univs:(Univ.ContextSet.to_context uctx) term + Declare.definition_entry ~types:termtype ~poly ~univs:uctx term in let cdecl = (DefinitionEntry entry, kind) in let kn = Declare.declare_constant id cdecl in Declare.definition_message id; + Universes.register_universe_binders (ConstRef kn) pl; instance_hook k pri global imps ?hook (ConstRef kn); id @@ -121,7 +123,9 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in - let evars = ref (Evd.from_env env) in + let ((loc, instid), pl) = instid in + let uctx = Evd.make_evar_universe_context env pl in + let evars = ref (Evd.from_ctx uctx) in let tclass, ids = match bk with | Implicit -> @@ -158,7 +162,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro cl, u, c', ctx', ctx, len, imps, args in let id = - match snd instid with + match instid with Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then @@ -185,11 +189,13 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro nf t in Evarutil.check_evars env Evd.empty !evars termtype; - let pl, ctx = Evd.universe_context !evars in + let pl, ctx = Evd.universe_context ?names:pl !evars in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id (ParameterEntry (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) - in instance_hook k None global imps ?hook (ConstRef cst); id + in + Universes.register_universe_binders (ConstRef cst) pl; + instance_hook k None global imps ?hook (ConstRef cst); id end else ( let props = @@ -282,9 +288,8 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro in let term = Option.map nf term in if not (Evd.has_undefined evm) && not (Option.is_empty term) then - let ctx = Evd.universe_context_set evm in - declare_instance_constant k pri global imps ?hook id - poly ctx (Option.get term) termtype + declare_instance_constant k pri global imps ?hook id pl + poly evm (Option.get term) termtype else if !refine_instance || Option.is_empty term then begin let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if Flags.is_program_mode () then @@ -304,7 +309,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let hook = Lemmas.mk_hook hook in let ctx = Evd.evar_universe_context evm in ignore (Obligations.add_definition id ?term:constr - typ ctx ~kind:(Global,poly,Instance) ~hook obls); + ?pl typ ctx ~kind:(Global,poly,Instance) ~hook obls); id else (Flags.silently diff --git a/toplevel/classes.mli b/toplevel/classes.mli index 24c51b31a..d600b3104 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -31,8 +31,9 @@ val declare_instance_constant : Impargs.manual_explicitation list -> (** implicits *) ?hook:(Globnames.global_reference -> unit) -> Id.t -> (** name *) + Id.t Loc.located list option -> bool -> (* polymorphic *) - Univ.universe_context_set -> (* Universes *) + Evd.evar_map -> (* Universes *) Constr.t -> (** body *) Term.types -> (** type *) Names.Id.t diff --git a/toplevel/command.ml b/toplevel/command.ml index 5d2a7638a..8f7c38997 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -177,7 +177,9 @@ let _ = Obligations.declare_definition_ref := (fun i k c imps hook -> declare_definition i k c [] imps hook) let do_definition ident k pl bl red_option c ctypopt hook = - let (ce, evd, pl, imps as def) = interp_definition pl bl (pi2 k) red_option c ctypopt in + let (ce, evd, pl', imps as def) = + interp_definition pl bl (pi2 k) red_option c ctypopt + in if Flags.is_program_mode () then let env = Global.env () in let (c,ctx), sideff = Future.force ce.const_entry_body in @@ -194,9 +196,9 @@ let do_definition ident k pl bl red_option c ctypopt hook = let ctx = Evd.evar_universe_context evd in let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in ignore(Obligations.add_definition - ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls) + ident ~term:c cty ctx ?pl ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in - ignore(declare_definition ident k ce pl imps + ignore(declare_definition ident k ce pl' imps (Lemmas.mk_hook (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) @@ -905,10 +907,11 @@ let nf_evar_context sigma ctx = List.map (fun (n, b, t) -> (n, Option.map (Evarutil.nf_evar sigma) b, Evarutil.nf_evar sigma t)) ctx -let build_wellfounded (recname,n,bl,arityc,body) r measure notation = +let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = Coqlib.check_required_library ["Coq";"Program";"Wf"]; let env = Global.env() in - let evdref = ref (Evd.from_env env) in + let ctx = Evd.make_evar_universe_context env pl in + let evdref = ref (Evd.from_ctx ctx) in let _, ((env', binders_rel), impls) = interp_context_evars env evdref bl in let len = List.length binders_rel in let top_env = push_rel_context binders_rel env in @@ -1014,9 +1017,9 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let hook l gr _ = let body = it_mkLambda_or_LetIn (mkApp (Universes.constr_of_global gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in - let pl, univs = Evd.universe_context !evdref in + let pl, univs = Evd.universe_context ?names:pl !evdref in (*FIXME poly? *) - let ce = definition_entry ~types:ty ~univs (Evarutil.nf_evar !evdref body) in + let ce = definition_entry ~poly ~types:ty ~univs (Evarutil.nf_evar !evdref body) in (** FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in @@ -1040,7 +1043,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp in let ctx = Evd.evar_universe_context !evdref in - ignore(Obligations.add_definition recname ~term:evars_def + ignore(Obligations.add_definition recname ~term:evars_def ?pl evars_typ ctx evars ~hook) let interp_recursive isfix fixl notations = @@ -1261,22 +1264,22 @@ let do_program_recursive local p fixkind fixl ntns = | Obligations.IsFixpoint _ -> (local, p, Fixpoint) | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) in - Obligations.add_mutual_definitions defs ~kind ctx ntns fixkind + Obligations.add_mutual_definitions defs ~kind ?pl ctx ntns fixkind let do_program_fixpoint local poly l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with - | [(n, CWfRec r)], [((((_,id),_),_,bl,typ,def),ntn)] -> + | [(n, CWfRec r)], [((((_,id),pl),_,bl,typ,def),ntn)] -> let recarg = match n with | Some n -> mkIdentC (snd n) | None -> errorlabstrm "do_program_fixpoint" (str "Recursive argument required for well-founded fixpoints") - in build_wellfounded (id, n, bl, typ, out_def def) r recarg ntn + in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn - | [(n, CMeasureRec (m, r))], [((((_,id),_),_,bl,typ,def),ntn)] -> - build_wellfounded (id, n, bl, typ, out_def def) + | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] -> + build_wellfounded (id, pl, n, bl, typ, out_def def) poly (Option.default (CRef (lt_ref,None)) r) m ntn | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 314789ced..7e0d30a63 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -311,6 +311,7 @@ type program_info_aux = { prg_body: constr; prg_type: constr; prg_ctx: Evd.evar_universe_context; + prg_pl: Id.t Loc.located list option; prg_obligations: obligations; prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; @@ -510,15 +511,21 @@ let declare_definition prg = (Evd.evar_universe_context_subst prg.prg_ctx) in let opaque = prg.prg_opaque in let fix_exn = Stm.get_fix_exn () in + let pl, ctx = + Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in let ce = definition_entry ~fix_exn ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind) ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body) in - progmap_remove prg; + let () = progmap_remove prg in + let cst = !declare_definition_ref prg.prg_name - prg.prg_kind ce prg.prg_implicits - (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r)) + prg.prg_kind ce prg.prg_implicits + (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r)) + in + Universes.register_universe_binders cst pl; + cst open Pp @@ -644,7 +651,8 @@ let declare_obligation prg obl body ty uctx = else Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) } -let init_prog_info ?(opaque = false) sign n b t ctx deps fixkind notations obls impls kind reduce hook = +let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind + notations obls impls kind reduce hook = let obls', b = match b with | None -> @@ -664,7 +672,7 @@ let init_prog_info ?(opaque = false) sign n b t ctx deps fixkind notations obls obls, b in { prg_name = n ; prg_body = b; prg_type = reduce t; - prg_ctx = ctx; + prg_ctx = ctx; prg_pl = pl; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; @@ -995,11 +1003,11 @@ let show_term n = Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) -let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic +let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = let sign = Decls.initialize_named_context_for_proof () in let info = str (Id.to_string n) ++ str " has type-checked" in - let prg = init_prog_info sign ~opaque n term t ctx [] None [] obls implicits kind reduce hook in + let prg = init_prog_info sign ~opaque n pl term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose msg_info (info ++ str "."); @@ -1014,13 +1022,13 @@ let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) -let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) +let add_mutual_definitions l ctx ?pl ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = let sign = Decls.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info sign ~opaque n (Some b) t ctx deps (Some fixkind) + let prg = init_prog_info sign ~opaque n pl (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook in progmap_add n (Ephemeron.create prg)) l; let _defined = diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index b2320a578..e257da016 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -64,6 +64,7 @@ val get_proofs_transparency : unit -> bool val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> Evd.evar_universe_context -> + ?pl:(Id.t Loc.located list) -> (* Universe binders *) ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> @@ -81,6 +82,7 @@ val add_mutual_definitions : (Names.Id.t * Term.constr * Term.types * (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list -> Evd.evar_universe_context -> + ?pl:(Id.t Loc.located list) -> (* Universe binders *) ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> |