diff options
-rw-r--r-- | intf/decl_kinds.mli | 2 | ||||
-rw-r--r-- | intf/vernacexpr.mli | 2 | ||||
-rw-r--r-- | kernel/declarations.mli | 4 | ||||
-rw-r--r-- | kernel/declareops.ml | 3 | ||||
-rw-r--r-- | kernel/entries.mli | 3 | ||||
-rw-r--r-- | kernel/indtypes.ml | 6 | ||||
-rw-r--r-- | kernel/modops.ml | 5 | ||||
-rw-r--r-- | library/declare.ml | 3 | ||||
-rw-r--r-- | parsing/g_vernac.ml4 | 12 | ||||
-rw-r--r-- | plugins/funind/glob_term_to_relation.ml | 6 | ||||
-rw-r--r-- | plugins/funind/merge.ml | 3 | ||||
-rw-r--r-- | pretyping/cases.ml | 1 | ||||
-rw-r--r-- | pretyping/indrec.ml | 22 | ||||
-rw-r--r-- | pretyping/tacred.ml | 8 | ||||
-rw-r--r-- | pretyping/tacred.mli | 5 | ||||
-rw-r--r-- | printing/ppvernac.ml | 2 | ||||
-rw-r--r-- | stm/vernac_classifier.ml | 2 | ||||
-rw-r--r-- | tactics/equality.ml | 6 | ||||
-rw-r--r-- | toplevel/command.ml | 9 | ||||
-rw-r--r-- | toplevel/command.mli | 6 | ||||
-rw-r--r-- | toplevel/discharge.ml | 1 | ||||
-rw-r--r-- | toplevel/record.ml | 1 | ||||
-rw-r--r-- | toplevel/vernacentries.ml | 6 |
23 files changed, 82 insertions, 36 deletions
diff --git a/intf/decl_kinds.mli b/intf/decl_kinds.mli index 2ed776c2d..ff77d718b 100644 --- a/intf/decl_kinds.mli +++ b/intf/decl_kinds.mli @@ -14,6 +14,8 @@ type binding_kind = Explicit | Implicit type polymorphic = bool +type private_flag = bool + type theorem_kind = | Theorem | Lemma diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index ed6ded8e1..0b2e55941 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -296,7 +296,7 @@ type vernac_expr = | VernacExactProof of constr_expr | VernacAssumption of (locality option * assumption_object_kind) * inline * simple_binder with_coercion list - | VernacInductive of inductive_flag * infer_flag * (inductive_expr * decl_notation list) list + | VernacInductive of private_flag * inductive_flag * infer_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of locality option * (fixpoint_expr * decl_notation list) list | VernacCoFixpoint of diff --git a/kernel/declarations.mli b/kernel/declarations.mli index f269e165e..9c7344f89 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -172,7 +172,9 @@ type mutual_inductive_body = { mind_universes : Univ.universe_context; (** Local universe variables and constraints *) - } + mind_private : bool option; (** allow pattern-matching: Some true ok, Some false blocked *) + +} (** {6 Module declarations } *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 92a566b7c..8806bba45 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -227,7 +227,8 @@ let subst_mind_body sub mib = Context.map_rel_context (subst_mps sub) mib.mind_params_ctxt; mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ; mind_polymorphic = mib.mind_polymorphic; - mind_universes = mib.mind_universes } + mind_universes = mib.mind_universes; + mind_private = mib.mind_private } (** {6 Hash-consing of inductive declarations } *) diff --git a/kernel/entries.mli b/kernel/entries.mli index 1bc3bbd15..a161a6fcb 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -46,7 +46,8 @@ type mutual_inductive_entry = { mind_entry_params : (Id.t * local_entry) list; mind_entry_inds : one_inductive_entry list; mind_entry_polymorphic : bool; - mind_entry_universes : Univ.universe_context } + mind_entry_universes : Univ.universe_context; + mind_entry_private : bool option } (** {6 Constants (Definition/Axiom) } *) type proof_output = constr * Declareops.side_effects diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index e89bbf0d9..73fdaa81f 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -628,6 +628,7 @@ let used_section_variables env inds = (fun l c -> Id.Set.union (Environ.global_vars_set env c) l) Id.Set.empty inds in keep_hyps env ids + let lift_decl n d = map_rel_declaration (lift n) d @@ -660,7 +661,7 @@ let compute_expansion ((kn, _ as ind), u) params ctx = (Array.map (fun p -> mkProj (p, mkRel 1)) projarr)) in exp, projarr -let build_inductive env p ctx env_ar params kn isrecord isfinite inds nmr recargs = +let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in @@ -743,6 +744,7 @@ let build_inductive env p ctx env_ar params kn isrecord isfinite inds nmr recarg mind_packets = packets; mind_polymorphic = p; mind_universes = ctx; + mind_private = prv; } (************************************************************************) @@ -757,7 +759,7 @@ let check_inductive env kn mie = (* Then check positivity conditions *) let (nmr,recargs) = check_positivity kn env_ar params inds in (* Build the inductive packets *) - build_inductive env mie.mind_entry_polymorphic + build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private mie.mind_entry_universes env_ar params kn mie.mind_entry_record mie.mind_entry_finite inds nmr recargs diff --git a/kernel/modops.ml b/kernel/modops.ml index 093ee7024..4c18ed275 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -308,6 +308,11 @@ let rec add_structure mp sign resolver linkinfo env = Environ.add_constant_key c cb linkinfo env |SFBmind mib -> let mind = mind_of_delta_kn resolver (KerName.make2 mp l) in + let mib = + if mib.mind_private != None then + { mib with mind_private = Some true } + else mib + in Environ.add_mind_key mind (mib,linkinfo) env |SFBmodule mb -> add_module mb linkinfo env (* adds components as well *) |SFBmodtype mtb -> Environ.add_modtype mtb env diff --git a/library/declare.ml b/library/declare.ml index 45015ac65..7fbf2f5ac 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -358,7 +358,8 @@ let dummy_inductive_entry (_,m) = ([],{ mind_entry_finite = true; mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; mind_entry_polymorphic = false; - mind_entry_universes = Univ.UContext.empty }) + mind_entry_universes = Univ.UContext.empty; + mind_entry_private = None }) type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index df3c18d10..05e654925 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -190,11 +190,11 @@ GEXTEND Gram | IDENT "Let"; id = identref; b = def_body -> VernacDefinition ((Some Discharge, Definition), id, b) (* Gallina inductive declarations *) - | f = finite_token; + | priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> let (k,f) = f in let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in - VernacInductive (f,false,indl) + VernacInductive (priv,f,false,indl) | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> VernacFixpoint (None, recs) | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> @@ -212,13 +212,14 @@ GEXTEND Gram ; gallina_ext: - [ [ b = record_token; infer = infer_token; oc = opt_coercion; name = identref; + [ [ priv = private_token; + b = record_token; infer = infer_token; oc = opt_coercion; name = identref; ps = binders; s = OPT [ ":"; s = lconstr -> s ]; cfs = [ ":="; l = constructor_list_or_record_decl -> l | -> RecordDecl (None, []) ] -> let (recf,indf) = b in - VernacInductive (indf,infer,[((oc,name),ps,s,recf,cfs),[]]) + VernacInductive (priv,indf,infer,[((oc,name),ps,s,recf,cfs),[]]) ] ] ; thm_token: @@ -260,6 +261,9 @@ GEXTEND Gram infer_token: [ [ IDENT "Infer" -> true | -> false ] ] ; + private_token: + [ [ IDENT "Private" -> true | -> false ] ] + ; record_token: [ [ IDENT "Record" -> (Record,BiFinite) | IDENT "Structure" -> (Structure,BiFinite) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 4544f736c..41970fce8 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1405,7 +1405,7 @@ let do_build_inductive (* in *) let _time2 = System.get_time () in try - with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds false)) true + with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds false false)) true with | UserError(s,msg) as e -> let _time3 = System.get_time () in @@ -1416,7 +1416,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ msg in @@ -1431,7 +1431,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ Errors.print reraise in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 2e524a35f..6eabe6e87 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -884,7 +884,8 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in - let mie,impls = Command.interp_mutual_inductive indl [] false (*FIXMEnon-poly *) true (* means: not coinductive *) in + let mie,impls = Command.interp_mutual_inductive indl [] + false (*FIXMEnon-poly *) false (* means not private *) true (* means: not coinductive *) in (* Declare the mutual inductive block with its associated schemes *) ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index b56d5947c..2b0a2dda9 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1298,6 +1298,7 @@ and match_current pb (initial,tomatch) = compile_all_variables initial tomatch pb | IsInd (_,(IndType(indf,realargs) as indt),names) -> let mind,_ = dest_ind_family indf in + let mind = Tacred.check_privacy pb.env mind in let cstrs = get_constructors pb.env indf in let arsign, _ = get_arity pb.env indf in let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 35a9cbdb2..bed77e622 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -45,6 +45,15 @@ let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c) (* Building curryfied elimination *) (*******************************************) +let is_private mib = + match mib.mind_private with + | Some true -> true + | _ -> false + +let check_privacy_block mib = + if is_private mib then + errorlabstrm ""(str"case analysis on a private inductive type") + (**********************************************************************) (* Building case analysis schemes *) (* Christine Paulin, 1996 *) @@ -54,12 +63,13 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let lnamespar = Vars.subst_univs_context usubst mib.mind_params_ctxt in - - if not (Sorts.List.mem kind (elim_sorts specif)) then - raise - (RecursionSchemeError - (NotAllowedCaseAnalysis (false, fst (Universes.fresh_sort_in_family env kind), pind))); - + let () = check_privacy_block mib in + let () = + if not (Sorts.List.mem kind (elim_sorts specif)) then + raise + (RecursionSchemeError + (NotAllowedCaseAnalysis (false, fst (Universes.fresh_sort_in_family env kind), pind))) + in let ndepar = mip.mind_nrealargs_ctxt + 1 in (* Pas génant car env ne sert pas à typer mais juste à renommer les Anonym *) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index da4595254..383d23306 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1093,6 +1093,10 @@ let pattern_occs loccs_trm env sigma c = (* Used in several tactics. *) +let check_privacy env ind = + if (fst (Inductive.lookup_mind_specif env (fst ind))).Declarations.mind_private = Some true then + errorlabstrm "" (str "case analysis on a private type") + else ind (* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name return name, B and t' *) @@ -1100,7 +1104,7 @@ let reduce_to_ind_gen allow_product env sigma t = let rec elimrec env t l = let t = hnf_constr env sigma t in match kind_of_term (fst (decompose_app t)) with - | Ind ind-> (ind, it_mkProd_or_LetIn t l) + | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) | Prod (n,ty,t') -> if allow_product then elimrec (push_rel (n,None,ty) env) t' ((n,None,ty)::l) @@ -1111,7 +1115,7 @@ let reduce_to_ind_gen allow_product env sigma t = was partially the case between V5.10 and V8.1 *) let t' = whd_betadeltaiota env sigma t in match kind_of_term (fst (decompose_app t')) with - | Ind ind-> (ind, it_mkProd_or_LetIn t' l) + | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) | _ -> errorlabstrm "" (str"Not an inductive product.") in elimrec env t [] diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 5146cd345..5e4bc5c46 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -14,6 +14,7 @@ open Reductionops open Pattern open Globnames open Locus +open Univ type reduction_tactic_error = InvalidAbstraction of env * constr * (env * Type_errors.type_error) @@ -106,3 +107,7 @@ val contextually : bool -> occurrences * constr_pattern -> val e_contextually : bool -> occurrences * constr_pattern -> (patvar_map -> e_reduction_function) -> e_reduction_function + +(** Returns the same inductive if it is allowed for pattern-matching + raises an error otherwise. **) +val check_privacy : env -> inductive puniverses -> inductive puniverses diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index e2d237815..6d7e3c38d 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -627,7 +627,7 @@ let rec pr_vernac = function hov 2 (pr_assumption_token (n > 1) stre ++ spc() ++ pr_ne_params_list pr_lconstr_expr l) - | VernacInductive (f,i,l) -> + | VernacInductive (p,f,i,l) -> let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 7a30923c8..fcfd616f4 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -126,7 +126,7 @@ let rec classify_vernac e = let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map snd l) l) in VtSideff ids, VtLater | VernacDefinition (_,(_,id),DefineBody _) -> VtSideff [id], VtLater - | VernacInductive (_,_,l) -> + | VernacInductive (_,_,_,l) -> let ids = List.map (fun (((_,(_,id)),_,_,_,cl),_) -> id :: match cl with | Constructors l -> List.map (fun (_,((_,id),_)) -> id) l | RecordDecl (oid,l) -> (match oid with Some (_,x) -> [x] | _ -> []) @ diff --git a/tactics/equality.ml b/tactics/equality.ml index 57931f600..eb8d27f25 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -755,7 +755,8 @@ let descend_then sigma env head dirn = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in - let (ind,_),_ = dest_ind_family indf in + let indp,_ = (dest_ind_family indf) in + let ind, _ = check_privacy env indp in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in @@ -804,7 +805,8 @@ let construct_discriminator sigma env dirn c sort = errorlabstrm "Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in - let ((ind,_),_) = dest_ind_family indf in + let (indp,_) = dest_ind_family indf in + let ind, _ = check_privacy env indp in let (mib,mip) = lookup_mind_specif env ind in let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in let deparsign = make_arity_signature env true indf in diff --git a/toplevel/command.ml b/toplevel/command.ml index 3f2a51888..22830eb6d 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -412,7 +412,7 @@ let inductive_levels env evdref arities inds = !evdref (Array.to_list levels') destarities sizes in evdref := evd; arities -let interp_mutual_inductive (paramsl,indl) notations poly finite = +let interp_mutual_inductive (paramsl,indl) notations poly prv finite = check_all_names_different indl; let env0 = Global.env() in let evdref = ref Evd.(from_env env0) in @@ -487,6 +487,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly finite = mind_entry_finite = finite; mind_entry_inds = entries; mind_entry_polymorphic = poly; + mind_entry_private = if prv then Some false else None; mind_entry_universes = Evd.universe_context evd }, impls @@ -535,7 +536,7 @@ let declare_mutual_inductive_with_eliminations isrecord mie impls = constrimpls) impls; if_verbose msg_info (minductive_message names); - declare_default_schemes mind; + if mie.mind_entry_private == None then declare_default_schemes mind; mind type one_inductive_impls = @@ -545,10 +546,10 @@ type one_inductive_impls = type one_inductive_expr = lident * local_binder list * constr_expr option * constructor_expr list -let do_mutual_inductive indl poly finite = +let do_mutual_inductive indl poly prv finite = let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in (* Interpret the types *) - let mie,impls = interp_mutual_inductive indl ntns poly finite in + let mie,impls = interp_mutual_inductive indl ntns poly prv finite in (* Declare the mutual inductive block with its associated schemes *) ignore (declare_mutual_inductive_with_eliminations UserVerbose mie impls); (* Declare the possible notations of inductive types *) diff --git a/toplevel/command.mli b/toplevel/command.mli index d2e601edd..41cb5baa3 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -86,7 +86,8 @@ type one_inductive_impls = Impargs.manual_implicits list (** for constrs *) val interp_mutual_inductive : - structured_inductive_expr -> decl_notation list -> polymorphic -> bool(*finite*) -> + structured_inductive_expr -> decl_notation list -> polymorphic -> + private_flag -> bool(*finite*) -> mutual_inductive_entry * one_inductive_impls list (** Registering a mutual inductive definition together with its @@ -99,7 +100,8 @@ val declare_mutual_inductive_with_eliminations : (** Entry points for the vernacular commands Inductive and CoInductive *) val do_mutual_inductive : - (one_inductive_expr * decl_notation list) list -> polymorphic -> bool -> unit + (one_inductive_expr * decl_notation list) list -> polymorphic -> + private_flag -> bool -> unit (** {6 Fixpoints and cofixpoints} *) diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index e17038a4f..5d0bcd78b 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -102,5 +102,6 @@ let process_inductive (sechyps,abs_ctx) modlist mib = mind_entry_params = params'; mind_entry_inds = inds'; mind_entry_polymorphic = mib.mind_polymorphic; + mind_entry_private = mib.mind_private; mind_entry_universes = univs } diff --git a/toplevel/record.ml b/toplevel/record.ml index b144dfe43..56493bae8 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -340,6 +340,7 @@ let declare_structure finite infer poly ctx id idbuild paramimpls params arity f mind_entry_finite = finite != CoFinite; mind_entry_inds = [mie_ind]; mind_entry_polymorphic = poly; + mind_entry_private = None; mind_entry_universes = ctx } in let kn = Command.declare_mutual_inductive_with_eliminations KernelVerbose mie [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index bb702f79f..ca31d1f2e 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -534,7 +534,7 @@ let vernac_record k poly finite infer struc binders sort nameopt cfs = | _ -> ()) cfs); ignore(Record.definition_structure (k,poly,finite,infer,struc,binders,cfs,const,sort)) -let vernac_inductive poly finite infer indl = +let vernac_inductive poly lo finite infer indl = if Dumpglob.dump () then List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> match cstrs with @@ -565,7 +565,7 @@ let vernac_inductive poly finite infer indl = | _ -> Errors.error "Cannot handle mutually (co)inductive records." in let indl = List.map unpack indl in - do_mutual_inductive indl poly (finite != CoFinite) + do_mutual_inductive indl poly lo (finite != CoFinite) let vernac_fixpoint locality poly local l = let local = enforce_locality_exp locality local in @@ -1696,7 +1696,7 @@ let interp ?proof locality poly c = | VernacEndProof e -> vernac_end_proof ?proof e | VernacExactProof c -> vernac_exact_proof c | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl - | VernacInductive (finite,infer,l) -> vernac_inductive poly finite infer l + | VernacInductive (priv,finite,infer,l) -> vernac_inductive poly priv finite infer l | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l | VernacScheme l -> vernac_scheme l |