diff options
| author |  Yves Bertot <bertot@inria.fr> | 2013-03-02 14:00:46 -0500 |
|---|---|---|
| committer |  Matthieu Sozeau <mattam@mattam.org> | 2014-05-06 09:58:57 +0200 |
| commit | 8a905458039b631165d068bbf62f88e11eb36eb1 (patch) | |
| tree | f4f96ea7b7d482fc79acb6edb3b1c96aec2555a5 /pretyping/indrec.ml | |
| parent | 29794b8acf407518716f8c02c2ed20729f8802e5 (diff) | |
Adapt Y. Bertot's path on private inductives (now the keyword is "Private").
A quick and dirty approach to private inductive types
Types for which computable functions are provided, but pattern-matching is disallowed.
This kind of type can be used to simulate simple forms of higher inductive types, with
convertibility for applications of the inductive principle to 0-constructors
Conflicts:
intf/vernacexpr.mli
kernel/declarations.ml
kernel/declarations.mli
kernel/entries.mli
kernel/indtypes.ml
library/declare.ml
parsing/g_vernac.ml4
plugins/funind/glob_term_to_relation.ml
pretyping/indrec.ml
pretyping/tacred.mli
printing/ppvernac.ml
toplevel/vernacentries.ml
Conflicts:
kernel/declarations.mli
kernel/declareops.ml
kernel/indtypes.ml
kernel/modops.ml
Diffstat (limited to 'pretyping/indrec.ml')
| -rw-r--r-- | pretyping/indrec.ml | 22 |
1 files changed, 16 insertions, 6 deletions
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 *) |