author | wenzelm |
Fri, 14 Aug 2020 14:40:24 +0200 | |
changeset 72154 | 2b41b710f6ef |
parent 71253 | a62431901140 |
child 72450 | 24bd1316eaae |
permissions | -rw-r--r-- |
54701 | 1 |
(* Title: HOL/Tools/Ctr_Sugar/ctr_sugar.ML |
49017 | 2 |
Author: Jasmin Blanchette, TU Muenchen |
59266 | 3 |
Author: Martin Desharnais, TU Muenchen |
54397 | 4 |
Copyright 2012, 2013 |
49017 | 5 |
|
51797 | 6 |
Wrapping existing freely generated type's constructors. |
49017 | 7 |
*) |
8 |
||
54006 | 9 |
signature CTR_SUGAR = |
49017 | 10 |
sig |
58675 | 11 |
datatype ctr_sugar_kind = Datatype | Codatatype | Record | Unknown |
12 |
||
51840 | 13 |
type ctr_sugar = |
58675 | 14 |
{kind: ctr_sugar_kind, |
15 |
T: typ, |
|
58187
d2ddd401d74d
fixed infinite loops in 'register' functions + more uniform API
blanchet
parents:
58186
diff
changeset
|
16 |
ctrs: term list, |
52375 | 17 |
casex: term, |
51839 | 18 |
discs: term list, |
51819 | 19 |
selss: term list list, |
20 |
exhaust: thm, |
|
52375 | 21 |
nchotomy: thm, |
51819 | 22 |
injects: thm list, |
23 |
distincts: thm list, |
|
24 |
case_thms: thm list, |
|
52375 | 25 |
case_cong: thm, |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
26 |
case_cong_weak: thm, |
59266 | 27 |
case_distribs: thm list, |
52375 | 28 |
split: thm, |
29 |
split_asm: thm, |
|
56858 | 30 |
disc_defs: thm list, |
51819 | 31 |
disc_thmss: thm list list, |
32 |
discIs: thm list, |
|
59271 | 33 |
disc_eq_cases: thm list, |
56858 | 34 |
sel_defs: thm list, |
53475 | 35 |
sel_thmss: thm list list, |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
36 |
distinct_discsss: thm list list list, |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
37 |
exhaust_discs: thm list, |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
38 |
exhaust_sels: thm list, |
53475 | 39 |
collapses: thm list, |
40 |
expands: thm list, |
|
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
41 |
split_sels: thm list, |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
42 |
split_sel_asms: thm list, |
54491 | 43 |
case_eq_ifs: thm list}; |
51809 | 44 |
|
51840 | 45 |
val morph_ctr_sugar: morphism -> ctr_sugar -> ctr_sugar |
58115 | 46 |
val transfer_ctr_sugar: theory -> ctr_sugar -> ctr_sugar |
53867
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
47 |
val ctr_sugar_of: Proof.context -> string -> ctr_sugar option |
58116 | 48 |
val ctr_sugar_of_global: theory -> string -> ctr_sugar option |
53906 | 49 |
val ctr_sugars_of: Proof.context -> ctr_sugar list |
58116 | 50 |
val ctr_sugars_of_global: theory -> ctr_sugar list |
54403 | 51 |
val ctr_sugar_of_case: Proof.context -> string -> ctr_sugar option |
58116 | 52 |
val ctr_sugar_of_case_global: theory -> string -> ctr_sugar option |
61760 | 53 |
val ctr_sugar_interpretation: string -> (ctr_sugar -> local_theory -> local_theory) -> theory -> |
54 |
theory |
|
58188 | 55 |
val interpret_ctr_sugar: (string -> bool) -> ctr_sugar -> local_theory -> local_theory |
58187
d2ddd401d74d
fixed infinite loops in 'register' functions + more uniform API
blanchet
parents:
58186
diff
changeset
|
56 |
val register_ctr_sugar_raw: ctr_sugar -> local_theory -> local_theory |
58188 | 57 |
val register_ctr_sugar: (string -> bool) -> ctr_sugar -> local_theory -> local_theory |
58 |
val default_register_ctr_sugar_global: (string -> bool) -> ctr_sugar -> theory -> theory |
|
51823
38996458bc5c
create data structure for storing (co)datatype information
blanchet
parents:
51819
diff
changeset
|
59 |
|
49585
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
60 |
val mk_half_pairss: 'a list * 'a list -> ('a * 'a) list list |
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
61 |
val join_halves: int -> 'a list list -> 'a list list -> 'a list * 'a list list list |
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
62 |
|
49203 | 63 |
val mk_ctr: typ list -> term -> term |
53864
a48d4bd3faaa
use case rather than sequence of ifs in expansion
blanchet
parents:
53857
diff
changeset
|
64 |
val mk_case: typ list -> typ -> term -> term |
49484 | 65 |
val mk_disc_or_sel: typ list -> term -> term |
49622 | 66 |
val name_of_ctr: term -> string |
51777
48a0ae342ea0
generate proper attributes for coinduction rules
blanchet
parents:
51771
diff
changeset
|
67 |
val name_of_disc: term -> string |
53888 | 68 |
val dest_ctr: Proof.context -> string -> term -> term * term list |
54970
891141de5672
only destruct cases equipped with the right stuff (in particular, 'sel_split')
blanchet
parents:
54900
diff
changeset
|
69 |
val dest_case: Proof.context -> string -> typ list -> term -> |
891141de5672
only destruct cases equipped with the right stuff (in particular, 'sel_split')
blanchet
parents:
54900
diff
changeset
|
70 |
(ctr_sugar * term list * term list) option |
49585
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
71 |
|
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
72 |
type ('c, 'a) ctr_spec = (binding * 'c) * 'a list |
55469
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
73 |
|
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
74 |
val disc_of_ctr_spec: ('c, 'a) ctr_spec -> binding |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
75 |
val ctr_of_ctr_spec: ('c, 'a) ctr_spec -> 'c |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
76 |
val args_of_ctr_spec: ('c, 'a) ctr_spec -> 'a list |
55469
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
77 |
|
59283 | 78 |
val code_plugin: string |
79 |
||
58191 | 80 |
type ctr_options = (string -> bool) * bool |
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
81 |
type ctr_options_cmd = (Proof.context -> string -> bool) * bool |
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
82 |
|
57830
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
83 |
val fake_local_theory_for_sel_defaults: (binding * typ) list -> Proof.context -> Proof.context |
58675 | 84 |
val free_constructors: ctr_sugar_kind -> |
85 |
({prems: thm list, context: Proof.context} -> tactic) list list -> |
|
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
86 |
((ctr_options * binding) * (term, binding) ctr_spec list) * term list -> local_theory -> |
51840 | 87 |
ctr_sugar * local_theory |
61301 | 88 |
val free_constructors_cmd: ctr_sugar_kind -> |
89 |
((((Proof.context -> Plugin_Name.filter) * bool) * binding) |
|
90 |
* ((binding * string) * binding list) list) * string list -> |
|
91 |
Proof.context -> Proof.state |
|
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
92 |
val default_ctr_options: ctr_options |
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
93 |
val default_ctr_options_cmd: ctr_options_cmd |
49286 | 94 |
val parse_bound_term: (binding * string) parser |
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
95 |
val parse_ctr_options: ctr_options_cmd parser |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
96 |
val parse_ctr_spec: 'c parser -> 'a parser -> ('c, 'a) ctr_spec parser |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
97 |
val parse_sel_default_eqs: string list parser |
49017 | 98 |
end; |
99 |
||
54006 | 100 |
structure Ctr_Sugar : CTR_SUGAR = |
49017 | 101 |
struct |
102 |
||
54008
b15cfc2864de
refactoring -- splitting between constructor sugar dependencies and true BNF dependencies
blanchet
parents:
54007
diff
changeset
|
103 |
open Ctr_Sugar_Util |
54006 | 104 |
open Ctr_Sugar_Tactics |
54615
62fb5af93fe2
generalized datatype code generation code so that it works with old-style and new-style (co)datatypes (as long as they are not local)
blanchet
parents:
54493
diff
changeset
|
105 |
open Ctr_Sugar_Code |
49017 | 106 |
|
58675 | 107 |
datatype ctr_sugar_kind = Datatype | Codatatype | Record | Unknown; |
108 |
||
51840 | 109 |
type ctr_sugar = |
58675 | 110 |
{kind: ctr_sugar_kind, |
111 |
T: typ, |
|
58187
d2ddd401d74d
fixed infinite loops in 'register' functions + more uniform API
blanchet
parents:
58186
diff
changeset
|
112 |
ctrs: term list, |
52375 | 113 |
casex: term, |
51839 | 114 |
discs: term list, |
51819 | 115 |
selss: term list list, |
116 |
exhaust: thm, |
|
52375 | 117 |
nchotomy: thm, |
51819 | 118 |
injects: thm list, |
119 |
distincts: thm list, |
|
120 |
case_thms: thm list, |
|
52375 | 121 |
case_cong: thm, |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
122 |
case_cong_weak: thm, |
59266 | 123 |
case_distribs: thm list, |
52375 | 124 |
split: thm, |
125 |
split_asm: thm, |
|
56858 | 126 |
disc_defs: thm list, |
51819 | 127 |
disc_thmss: thm list list, |
128 |
discIs: thm list, |
|
59271 | 129 |
disc_eq_cases: thm list, |
56858 | 130 |
sel_defs: thm list, |
53475 | 131 |
sel_thmss: thm list list, |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
132 |
distinct_discsss: thm list list list, |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
133 |
exhaust_discs: thm list, |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
134 |
exhaust_sels: thm list, |
53475 | 135 |
collapses: thm list, |
136 |
expands: thm list, |
|
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
137 |
split_sels: thm list, |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
138 |
split_sel_asms: thm list, |
54491 | 139 |
case_eq_ifs: thm list}; |
51809 | 140 |
|
58685 | 141 |
fun morph_ctr_sugar phi ({kind, T, ctrs, casex, discs, selss, exhaust, nchotomy, injects, distincts, |
59266 | 142 |
case_thms, case_cong, case_cong_weak, case_distribs, split, split_asm, disc_defs, disc_thmss, |
59271 | 143 |
discIs, disc_eq_cases, sel_defs, sel_thmss, distinct_discsss, exhaust_discs, exhaust_sels, |
144 |
collapses, expands, split_sels, split_sel_asms, case_eq_ifs} : ctr_sugar) = |
|
58675 | 145 |
{kind = kind, |
146 |
T = Morphism.typ phi T, |
|
58187
d2ddd401d74d
fixed infinite loops in 'register' functions + more uniform API
blanchet
parents:
58186
diff
changeset
|
147 |
ctrs = map (Morphism.term phi) ctrs, |
52375 | 148 |
casex = Morphism.term phi casex, |
51839 | 149 |
discs = map (Morphism.term phi) discs, |
51823
38996458bc5c
create data structure for storing (co)datatype information
blanchet
parents:
51819
diff
changeset
|
150 |
selss = map (map (Morphism.term phi)) selss, |
38996458bc5c
create data structure for storing (co)datatype information
blanchet
parents:
51819
diff
changeset
|
151 |
exhaust = Morphism.thm phi exhaust, |
52375 | 152 |
nchotomy = Morphism.thm phi nchotomy, |
51823
38996458bc5c
create data structure for storing (co)datatype information
blanchet
parents:
51819
diff
changeset
|
153 |
injects = map (Morphism.thm phi) injects, |
38996458bc5c
create data structure for storing (co)datatype information
blanchet
parents:
51819
diff
changeset
|
154 |
distincts = map (Morphism.thm phi) distincts, |
38996458bc5c
create data structure for storing (co)datatype information
blanchet
parents:
51819
diff
changeset
|
155 |
case_thms = map (Morphism.thm phi) case_thms, |
52375 | 156 |
case_cong = Morphism.thm phi case_cong, |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
157 |
case_cong_weak = Morphism.thm phi case_cong_weak, |
59266 | 158 |
case_distribs = map (Morphism.thm phi) case_distribs, |
52375 | 159 |
split = Morphism.thm phi split, |
160 |
split_asm = Morphism.thm phi split_asm, |
|
56858 | 161 |
disc_defs = map (Morphism.thm phi) disc_defs, |
51823
38996458bc5c
create data structure for storing (co)datatype information
blanchet
parents:
51819
diff
changeset
|
162 |
disc_thmss = map (map (Morphism.thm phi)) disc_thmss, |
38996458bc5c
create data structure for storing (co)datatype information
blanchet
parents:
51819
diff
changeset
|
163 |
discIs = map (Morphism.thm phi) discIs, |
59271 | 164 |
disc_eq_cases = map (Morphism.thm phi) disc_eq_cases, |
56858 | 165 |
sel_defs = map (Morphism.thm phi) sel_defs, |
53475 | 166 |
sel_thmss = map (map (Morphism.thm phi)) sel_thmss, |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
167 |
distinct_discsss = map (map (map (Morphism.thm phi))) distinct_discsss, |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
168 |
exhaust_discs = map (Morphism.thm phi) exhaust_discs, |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
169 |
exhaust_sels = map (Morphism.thm phi) exhaust_sels, |
53475 | 170 |
collapses = map (Morphism.thm phi) collapses, |
171 |
expands = map (Morphism.thm phi) expands, |
|
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
172 |
split_sels = map (Morphism.thm phi) split_sels, |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
173 |
split_sel_asms = map (Morphism.thm phi) split_sel_asms, |
54491 | 174 |
case_eq_ifs = map (Morphism.thm phi) case_eq_ifs}; |
51823
38996458bc5c
create data structure for storing (co)datatype information
blanchet
parents:
51819
diff
changeset
|
175 |
|
58115 | 176 |
val transfer_ctr_sugar = morph_ctr_sugar o Morphism.transfer_morphism; |
53867
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
177 |
|
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
178 |
structure Data = Generic_Data |
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
179 |
( |
71248 | 180 |
type T = (Position.T * ctr_sugar) Symtab.table; |
53867
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
181 |
val empty = Symtab.empty; |
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
182 |
val extend = I; |
55394
d5ebe055b599
more liberal merging of BNFs and constructor sugar
blanchet
parents:
55356
diff
changeset
|
183 |
fun merge data : T = Symtab.merge (K true) data; |
53867
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
184 |
); |
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
185 |
|
58116 | 186 |
fun ctr_sugar_of_generic context = |
71248 | 187 |
Option.map (transfer_ctr_sugar (Context.theory_of context) o #2) o Symtab.lookup (Data.get context); |
58116 | 188 |
|
189 |
fun ctr_sugars_of_generic context = |
|
71248 | 190 |
Symtab.fold (cons o transfer_ctr_sugar (Context.theory_of context) o #2 o #2) (Data.get context) []; |
53906 | 191 |
|
58116 | 192 |
fun ctr_sugar_of_case_generic context s = |
193 |
find_first (fn {casex = Const (s', _), ...} => s' = s | _ => false) |
|
194 |
(ctr_sugars_of_generic context); |
|
53867
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
195 |
|
58116 | 196 |
val ctr_sugar_of = ctr_sugar_of_generic o Context.Proof; |
197 |
val ctr_sugar_of_global = ctr_sugar_of_generic o Context.Theory; |
|
198 |
||
199 |
val ctr_sugars_of = ctr_sugars_of_generic o Context.Proof; |
|
200 |
val ctr_sugars_of_global = ctr_sugars_of_generic o Context.Theory; |
|
201 |
||
202 |
val ctr_sugar_of_case = ctr_sugar_of_case_generic o Context.Proof; |
|
203 |
val ctr_sugar_of_case_global = ctr_sugar_of_case_generic o Context.Theory; |
|
54403 | 204 |
|
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
205 |
structure Ctr_Sugar_Plugin = Plugin(type T = ctr_sugar); |
56345 | 206 |
|
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
207 |
fun ctr_sugar_interpretation name f = |
62322 | 208 |
Ctr_Sugar_Plugin.interpretation name (fn ctr_sugar => fn lthy => |
209 |
f (transfer_ctr_sugar (Proof_Context.theory_of lthy) ctr_sugar) lthy); |
|
56376
5a93b8f928a2
added same idiomatic handling of namings for Ctr_Sugar/BNF-related interpretation hooks as for typedef and (old-style) datatypes
blanchet
parents:
56345
diff
changeset
|
210 |
|
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
211 |
val interpret_ctr_sugar = Ctr_Sugar_Plugin.data; |
58187
d2ddd401d74d
fixed infinite loops in 'register' functions + more uniform API
blanchet
parents:
58186
diff
changeset
|
212 |
|
71248 | 213 |
fun register_ctr_sugar_raw (ctr_sugar as {T = Type (name, _), ...}) = |
54285
578371ba74cc
reverted 3e1d230f1c00 -- pervasiveness is useful, cf. Coinductive_Nat in the AFP
blanchet
parents:
54265
diff
changeset
|
214 |
Local_Theory.declaration {syntax = false, pervasive = true} |
71248 | 215 |
(fn phi => fn context => |
216 |
let val pos = Position.thread_data () |
|
217 |
in Data.map (Symtab.update (name, (pos, morph_ctr_sugar phi ctr_sugar))) context end); |
|
53867
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
218 |
|
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
219 |
fun register_ctr_sugar plugins ctr_sugar = |
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
220 |
register_ctr_sugar_raw ctr_sugar #> interpret_ctr_sugar plugins ctr_sugar; |
58187
d2ddd401d74d
fixed infinite loops in 'register' functions + more uniform API
blanchet
parents:
58186
diff
changeset
|
221 |
|
71248 | 222 |
fun default_register_ctr_sugar_global plugins (ctr_sugar as {T = Type (name, _), ...}) thy = |
223 |
let |
|
224 |
val tab = Data.get (Context.Theory thy); |
|
225 |
val pos = Position.thread_data (); |
|
226 |
in |
|
227 |
if Symtab.defined tab name then thy |
|
56345 | 228 |
else |
229 |
thy |
|
71248 | 230 |
|> Context.theory_map (Data.put (Symtab.update_new (name, (pos, ctr_sugar)) tab)) |
58665 | 231 |
|> Named_Target.theory_map (Ctr_Sugar_Plugin.data plugins ctr_sugar) |
56345 | 232 |
end; |
54400 | 233 |
|
62322 | 234 |
val is_prefix = "is_"; |
235 |
val un_prefix = "un_"; |
|
236 |
val not_prefix = "not_"; |
|
57629
e88b5f59cade
use the noted theorem whenever possible, because it has a named derivation (leading to cleaner proof terms)
blanchet
parents:
57260
diff
changeset
|
237 |
|
62322 | 238 |
fun mk_unN 1 1 suf = un_prefix ^ suf |
239 |
| mk_unN _ l suf = un_prefix ^ suf ^ string_of_int l; |
|
49046
3c5eba97d93a
allow default names for selectors via wildcard (_) + fix wrong index (k)
blanchet
parents:
49045
diff
changeset
|
240 |
|
49594
55e798614c45
tweaked theorem names (in particular, dropped s's)
blanchet
parents:
49591
diff
changeset
|
241 |
val caseN = "case"; |
49054 | 242 |
val case_congN = "case_cong"; |
54491 | 243 |
val case_eq_ifN = "case_eq_if"; |
49118 | 244 |
val collapseN = "collapse"; |
53694 | 245 |
val discN = "disc"; |
59272 | 246 |
val disc_eq_caseN = "disc_eq_case"; |
53700 | 247 |
val discIN = "discI"; |
49054 | 248 |
val distinctN = "distinct"; |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
249 |
val distinct_discN = "distinct_disc"; |
49075 | 250 |
val exhaustN = "exhaust"; |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
251 |
val exhaust_discN = "exhaust_disc"; |
49486 | 252 |
val expandN = "expand"; |
49075 | 253 |
val injectN = "inject"; |
254 |
val nchotomyN = "nchotomy"; |
|
53694 | 255 |
val selN = "sel"; |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
256 |
val exhaust_selN = "exhaust_sel"; |
49054 | 257 |
val splitN = "split"; |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
258 |
val split_asmN = "split_asm"; |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
259 |
val split_selN = "split_sel"; |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
260 |
val split_sel_asmN = "split_sel_asm"; |
49633 | 261 |
val splitsN = "splits"; |
57984
cbe9a16f8e11
added collection theorem for consistency and convenience
blanchet
parents:
57983
diff
changeset
|
262 |
val split_selsN = "split_sels"; |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
263 |
val case_cong_weak_thmsN = "case_cong_weak"; |
59266 | 264 |
val case_distribN = "case_distrib"; |
49019 | 265 |
|
53700 | 266 |
val cong_attrs = @{attributes [cong]}; |
53836 | 267 |
val dest_attrs = @{attributes [dest]}; |
53700 | 268 |
val safe_elim_attrs = @{attributes [elim!]}; |
269 |
val iff_attrs = @{attributes [iff]}; |
|
54145
297d1c603999
make sure that registered code equations are actually equations
blanchet
parents:
54008
diff
changeset
|
270 |
val inductsimp_attrs = @{attributes [induct_simp]}; |
297d1c603999
make sure that registered code equations are actually equations
blanchet
parents:
54008
diff
changeset
|
271 |
val nitpicksimp_attrs = @{attributes [nitpick_simp]}; |
49300 | 272 |
val simp_attrs = @{attributes [simp]}; |
49046
3c5eba97d93a
allow default names for selectors via wildcard (_) + fix wrong index (k)
blanchet
parents:
49045
diff
changeset
|
273 |
|
55480
59cc4a8bc28a
allow different functions to recurse on the same type, like in the old package
blanchet
parents:
55471
diff
changeset
|
274 |
fun unflat_lookup eq xs ys = map (fn xs' => permute_like_unique eq xs xs' ys); |
49258
84f13469d7f0
allow same selector name for several constructors
blanchet
parents:
49257
diff
changeset
|
275 |
|
49585
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
276 |
fun mk_half_pairss' _ ([], []) = [] |
49591
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49586
diff
changeset
|
277 |
| mk_half_pairss' indent (x :: xs, _ :: ys) = |
49585
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
278 |
indent @ fold_rev (cons o single o pair x) ys (mk_half_pairss' ([] :: indent) (xs, ys)); |
49486 | 279 |
|
49585
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
280 |
fun mk_half_pairss p = mk_half_pairss' [[]] p; |
49027 | 281 |
|
49486 | 282 |
fun join_halves n half_xss other_half_xss = |
55342 | 283 |
(splice (flat half_xss) (flat other_half_xss), |
284 |
map2 (map2 append) (Library.chop_groups n half_xss) |
|
285 |
(transpose (Library.chop_groups n other_half_xss))); |
|
49027 | 286 |
|
69593 | 287 |
fun mk_undefined T = Const (\<^const_name>\<open>undefined\<close>, T); |
49055 | 288 |
|
49500 | 289 |
fun mk_ctr Ts t = |
290 |
let val Type (_, Ts0) = body_type (fastype_of t) in |
|
54435
4a655e62ad34
fixed type variable confusion in 'datatype_new_compat'
blanchet
parents:
54422
diff
changeset
|
291 |
subst_nonatomic_types (Ts0 ~~ Ts) t |
49203 | 292 |
end; |
293 |
||
49536 | 294 |
fun mk_case Ts T t = |
295 |
let val (Type (_, Ts0), body) = strip_type (fastype_of t) |>> List.last in |
|
54435
4a655e62ad34
fixed type variable confusion in 'datatype_new_compat'
blanchet
parents:
54422
diff
changeset
|
296 |
subst_nonatomic_types ((body, T) :: (Ts0 ~~ Ts)) t |
49536 | 297 |
end; |
298 |
||
53864
a48d4bd3faaa
use case rather than sequence of ifs in expansion
blanchet
parents:
53857
diff
changeset
|
299 |
fun mk_disc_or_sel Ts t = |
54435
4a655e62ad34
fixed type variable confusion in 'datatype_new_compat'
blanchet
parents:
54422
diff
changeset
|
300 |
subst_nonatomic_types (snd (Term.dest_Type (domain_type (fastype_of t))) ~~ Ts) t; |
53864
a48d4bd3faaa
use case rather than sequence of ifs in expansion
blanchet
parents:
53857
diff
changeset
|
301 |
|
58284
f9b6af3017fd
nicer case names in the N2M case, similar to those generated by the old package (e.g. 'Cons_tree' instead of just 'Cons')
blanchet
parents:
58256
diff
changeset
|
302 |
val name_of_ctr = name_of_const "constructor" body_type; |
51777
48a0ae342ea0
generate proper attributes for coinduction rules
blanchet
parents:
51771
diff
changeset
|
303 |
|
48a0ae342ea0
generate proper attributes for coinduction rules
blanchet
parents:
51771
diff
changeset
|
304 |
fun name_of_disc t = |
48a0ae342ea0
generate proper attributes for coinduction rules
blanchet
parents:
51771
diff
changeset
|
305 |
(case head_of t of |
69597 | 306 |
Abs (_, _, \<^const>\<open>Not\<close> $ (t' $ Bound 0)) => |
62322 | 307 |
Long_Name.map_base_name (prefix not_prefix) (name_of_disc t') |
69593 | 308 |
| Abs (_, _, Const (\<^const_name>\<open>HOL.eq\<close>, _) $ Bound 0 $ t') => |
62322 | 309 |
Long_Name.map_base_name (prefix is_prefix) (name_of_disc t') |
69597 | 310 |
| Abs (_, _, \<^const>\<open>Not\<close> $ (Const (\<^const_name>\<open>HOL.eq\<close>, _) $ Bound 0 $ t')) => |
62322 | 311 |
Long_Name.map_base_name (prefix (not_prefix ^ is_prefix)) (name_of_disc t') |
58289 | 312 |
| t' => name_of_const "discriminator" (perhaps (try domain_type)) t'); |
49622 | 313 |
|
314 |
val base_name_of_ctr = Long_Name.base_name o name_of_ctr; |
|
49046
3c5eba97d93a
allow default names for selectors via wildcard (_) + fix wrong index (k)
blanchet
parents:
49045
diff
changeset
|
315 |
|
53888 | 316 |
fun dest_ctr ctxt s t = |
55342 | 317 |
let val (f, args) = Term.strip_comb t in |
53888 | 318 |
(case ctr_sugar_of ctxt s of |
319 |
SOME {ctrs, ...} => |
|
320 |
(case find_first (can (fo_match ctxt f)) ctrs of |
|
321 |
SOME f' => (f', args) |
|
322 |
| NONE => raise Fail "dest_ctr") |
|
323 |
| NONE => raise Fail "dest_ctr") |
|
324 |
end; |
|
325 |
||
53870 | 326 |
fun dest_case ctxt s Ts t = |
327 |
(case Term.strip_comb t of |
|
328 |
(Const (c, _), args as _ :: _) => |
|
329 |
(case ctr_sugar_of ctxt s of |
|
54970
891141de5672
only destruct cases equipped with the right stuff (in particular, 'sel_split')
blanchet
parents:
54900
diff
changeset
|
330 |
SOME (ctr_sugar as {casex = Const (case_name, _), discs = discs0, selss = selss0, ...}) => |
53870 | 331 |
if case_name = c then |
53924 | 332 |
let val n = length discs0 in |
333 |
if n < length args then |
|
334 |
let |
|
335 |
val (branches, obj :: leftovers) = chop n args; |
|
336 |
val discs = map (mk_disc_or_sel Ts) discs0; |
|
337 |
val selss = map (map (mk_disc_or_sel Ts)) selss0; |
|
338 |
val conds = map (rapp obj) discs; |
|
339 |
val branch_argss = map (fn sels => map (rapp obj) sels @ leftovers) selss; |
|
340 |
val branches' = map2 (curry Term.betapplys) branches branch_argss; |
|
341 |
in |
|
54970
891141de5672
only destruct cases equipped with the right stuff (in particular, 'sel_split')
blanchet
parents:
54900
diff
changeset
|
342 |
SOME (ctr_sugar, conds, branches') |
53924 | 343 |
end |
344 |
else |
|
345 |
NONE |
|
53870 | 346 |
end |
347 |
else |
|
348 |
NONE |
|
349 |
| _ => NONE) |
|
350 |
| _ => NONE); |
|
351 |
||
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
352 |
fun const_or_free_name (Const (s, _)) = Long_Name.base_name s |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
353 |
| const_or_free_name (Free (s, _)) = s |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
354 |
| const_or_free_name t = raise TERM ("const_or_free_name", [t]) |
49437 | 355 |
|
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
356 |
fun extract_sel_default ctxt t = |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
357 |
let |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
358 |
fun malformed () = |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
359 |
error ("Malformed selector default value equation: " ^ Syntax.string_of_term ctxt t); |
55469
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
360 |
|
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
361 |
val ((sel, (ctr, vars)), rhs) = |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
362 |
fst (Term.replace_dummy_patterns (Syntax.check_term ctxt t) 0) |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
363 |
|> HOLogic.dest_eq |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
364 |
|>> (Term.dest_comb |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
365 |
#>> const_or_free_name |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
366 |
##> (Term.strip_comb #>> (Term.dest_Const #> fst))) |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
367 |
handle TERM _ => malformed (); |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
368 |
in |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
369 |
if forall (is_Free orf is_Var) vars andalso not (has_duplicates (op aconv) vars) then |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
370 |
((ctr, sel), fold_rev Term.lambda vars rhs) |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
371 |
else |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
372 |
malformed () |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
373 |
end; |
55469
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
374 |
|
57830
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
375 |
(* Ideally, we would enrich the context with constants rather than free variables. *) |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
376 |
fun fake_local_theory_for_sel_defaults sel_bTs = |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
377 |
Proof_Context.allow_dummies |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
378 |
#> Proof_Context.add_fixes (map (fn (b, T) => (b, SOME T, NoSyn)) sel_bTs) |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
379 |
#> snd; |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
380 |
|
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
381 |
type ('c, 'a) ctr_spec = (binding * 'c) * 'a list; |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
382 |
|
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
383 |
fun disc_of_ctr_spec ((disc, _), _) = disc; |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
384 |
fun ctr_of_ctr_spec ((_, ctr), _) = ctr; |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
385 |
fun args_of_ctr_spec (_, args) = args; |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
386 |
|
69593 | 387 |
val code_plugin = Plugin_Name.declare_setup \<^binding>\<open>code\<close>; |
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
388 |
|
58675 | 389 |
fun prepare_free_constructors kind prep_plugins prep_term |
59281 | 390 |
((((raw_plugins, discs_sels), raw_case_binding), ctr_specs), sel_default_eqs) no_defs_lthy = |
49017 | 391 |
let |
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
392 |
val plugins = prep_plugins no_defs_lthy raw_plugins; |
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
393 |
|
49019 | 394 |
(* TODO: sanity checks on arguments *) |
49025 | 395 |
|
55469
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
396 |
val raw_ctrs = map ctr_of_ctr_spec ctr_specs; |
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
397 |
val raw_disc_bindings = map disc_of_ctr_spec ctr_specs; |
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
398 |
val raw_sel_bindingss = map args_of_ctr_spec ctr_specs; |
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
399 |
|
49280
52413dc96326
allow default values for selectors in low-level "wrap_data" command
blanchet
parents:
49278
diff
changeset
|
400 |
val n = length raw_ctrs; |
49054 | 401 |
val ks = 1 upto n; |
402 |
||
59281 | 403 |
val _ = n > 0 orelse error "No constructors specified"; |
49121 | 404 |
|
49280
52413dc96326
allow default values for selectors in low-level "wrap_data" command
blanchet
parents:
49278
diff
changeset
|
405 |
val ctrs0 = map (prep_term no_defs_lthy) raw_ctrs; |
52413dc96326
allow default values for selectors in low-level "wrap_data" command
blanchet
parents:
49278
diff
changeset
|
406 |
|
60279
351536745704
took out unreliable 'blast' from tactic altogether
blanchet
parents:
60251
diff
changeset
|
407 |
val (fcT_name, As0) = |
351536745704
took out unreliable 'blast' from tactic altogether
blanchet
parents:
60251
diff
changeset
|
408 |
(case body_type (fastype_of (hd ctrs0)) of |
351536745704
took out unreliable 'blast' from tactic altogether
blanchet
parents:
60251
diff
changeset
|
409 |
Type T' => T' |
351536745704
took out unreliable 'blast' from tactic altogether
blanchet
parents:
60251
diff
changeset
|
410 |
| _ => error "Expected type constructor in body type of constructor"); |
351536745704
took out unreliable 'blast' from tactic altogether
blanchet
parents:
60251
diff
changeset
|
411 |
val _ = forall ((fn Type (T_name, _) => T_name = fcT_name | _ => false) o body_type |
351536745704
took out unreliable 'blast' from tactic altogether
blanchet
parents:
60251
diff
changeset
|
412 |
o fastype_of) (tl ctrs0) orelse error "Constructors not constructing same type"; |
351536745704
took out unreliable 'blast' from tactic altogether
blanchet
parents:
60251
diff
changeset
|
413 |
|
53908 | 414 |
val fc_b_name = Long_Name.base_name fcT_name; |
415 |
val fc_b = Binding.name fc_b_name; |
|
49055 | 416 |
|
55410 | 417 |
fun qualify mandatory = Binding.qualify mandatory fc_b_name; |
49633 | 418 |
|
59266 | 419 |
val (unsorted_As, [B, C]) = |
49055 | 420 |
no_defs_lthy |
53268
de1dc709f9d4
handle type class annotations on (co)datatype parameters gracefully
blanchet
parents:
53210
diff
changeset
|
421 |
|> variant_tfrees (map (fst o dest_TFree_or_TVar) As0) |
59266 | 422 |
||> fst o mk_TFrees 2; |
49055 | 423 |
|
58234 | 424 |
val As = map2 (resort_tfree_or_tvar o snd o dest_TFree_or_TVar) As0 unsorted_As; |
53268
de1dc709f9d4
handle type class annotations on (co)datatype parameters gracefully
blanchet
parents:
53210
diff
changeset
|
425 |
|
53908 | 426 |
val fcT = Type (fcT_name, As); |
49055 | 427 |
val ctrs = map (mk_ctr As) ctrs0; |
428 |
val ctr_Tss = map (binder_types o fastype_of) ctrs; |
|
429 |
||
430 |
val ms = map length ctr_Tss; |
|
431 |
||
57091 | 432 |
fun can_definitely_rely_on_disc k = |
433 |
not (Binding.is_empty (nth raw_disc_bindings (k - 1))) orelse nth ms (k - 1) = 0; |
|
51790
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
434 |
fun can_rely_on_disc k = |
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
435 |
can_definitely_rely_on_disc k orelse (k = 1 andalso not (can_definitely_rely_on_disc 2)); |
53925 | 436 |
fun should_omit_disc_binding k = n = 1 orelse (n = 2 andalso can_rely_on_disc (3 - k)); |
51790
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
437 |
|
69593 | 438 |
val equal_binding = \<^binding>\<open>=\<close>; |
57090
0224caba67ca
use '%x. x = C' as default discriminator for nullary constructor C, instead of relying on odd '=:' syntax
blanchet
parents:
57038
diff
changeset
|
439 |
|
51790
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
440 |
fun is_disc_binding_valid b = |
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
441 |
not (Binding.is_empty b orelse Binding.eq_name (b, equal_binding)); |
51787
1267c28c7bdd
changed discriminator default: avoid mixing ctor and dtor views
blanchet
parents:
51781
diff
changeset
|
442 |
|
62322 | 443 |
val standard_disc_binding = Binding.name o prefix is_prefix o base_name_of_ctr; |
49120
7f8e69fc6ac9
smarter "*" syntax -- fallback on "_" if "*" is impossible
blanchet
parents:
49119
diff
changeset
|
444 |
|
49336 | 445 |
val disc_bindings = |
55470
46e6e1d91056
removed needless robustness (no longer needed thanks to new syntax)
blanchet
parents:
55469
diff
changeset
|
446 |
raw_disc_bindings |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
447 |
|> @{map 4} (fn k => fn m => fn ctr => fn disc => |
51790
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
448 |
qualify false |
51787
1267c28c7bdd
changed discriminator default: avoid mixing ctor and dtor views
blanchet
parents:
51781
diff
changeset
|
449 |
(if Binding.is_empty disc then |
57091 | 450 |
if m = 0 then equal_binding |
451 |
else if should_omit_disc_binding k then disc |
|
57090
0224caba67ca
use '%x. x = C' as default discriminator for nullary constructor C, instead of relying on odd '=:' syntax
blanchet
parents:
57038
diff
changeset
|
452 |
else standard_disc_binding ctr |
51790
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
453 |
else if Binding.eq_name (disc, standard_binding) then |
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
454 |
standard_disc_binding ctr |
49302
f5bd87aac224
added optional qualifiers for constructors and destructors, similarly to the old package
blanchet
parents:
49300
diff
changeset
|
455 |
else |
51790
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
456 |
disc)) ks ms ctrs0; |
49056 | 457 |
|
51787
1267c28c7bdd
changed discriminator default: avoid mixing ctor and dtor views
blanchet
parents:
51781
diff
changeset
|
458 |
fun standard_sel_binding m l = Binding.name o mk_unN m l o base_name_of_ctr; |
49120
7f8e69fc6ac9
smarter "*" syntax -- fallback on "_" if "*" is impossible
blanchet
parents:
49119
diff
changeset
|
459 |
|
49336 | 460 |
val sel_bindingss = |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
461 |
@{map 3} (fn ctr => fn m => map2 (fn l => fn sel => |
49633 | 462 |
qualify false |
51790
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
463 |
(if Binding.is_empty sel orelse Binding.eq_name (sel, standard_binding) then |
51787
1267c28c7bdd
changed discriminator default: avoid mixing ctor and dtor views
blanchet
parents:
51781
diff
changeset
|
464 |
standard_sel_binding m l ctr |
49302
f5bd87aac224
added optional qualifiers for constructors and destructors, similarly to the old package
blanchet
parents:
49300
diff
changeset
|
465 |
else |
55470
46e6e1d91056
removed needless robustness (no longer needed thanks to new syntax)
blanchet
parents:
55469
diff
changeset
|
466 |
sel)) (1 upto m) o pad_list Binding.empty m) ctrs0 ms raw_sel_bindingss; |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
49019
diff
changeset
|
467 |
|
61550
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
468 |
val add_bindings = |
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
469 |
Variable.add_fixes (distinct (op =) (filter Symbol_Pos.is_identifier |
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
470 |
(map Binding.name_of (disc_bindings @ flat sel_bindingss)))) |
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
471 |
#> snd; |
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
472 |
|
49201 | 473 |
val case_Ts = map (fn Ts => Ts ---> B) ctr_Tss; |
49043 | 474 |
|
62320 | 475 |
val (((((((((u, exh_y), xss), yss), fs), gs), w), (p, p'))), _) = no_defs_lthy |
61550
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
476 |
|> add_bindings |
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
477 |
|> yield_singleton (mk_Frees fc_b_name) fcT |
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
478 |
||>> yield_singleton (mk_Frees "y") fcT (* for compatibility with "datatype_realizer.ML" *) |
61272
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
479 |
||>> mk_Freess "x" ctr_Tss |
49025 | 480 |
||>> mk_Freess "y" ctr_Tss |
49201 | 481 |
||>> mk_Frees "f" case_Ts |
482 |
||>> mk_Frees "g" case_Ts |
|
61272
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
483 |
||>> yield_singleton (mk_Frees "z") B |
67405
e9ab4ad7bd15
uniform use of Standard ML op-infix -- eliminated warnings;
wenzelm
parents:
67399
diff
changeset
|
484 |
||>> yield_singleton (apfst (op ~~) oo mk_Frees' "P") HOLogic.boolT; |
49043 | 485 |
|
49463 | 486 |
val q = Free (fst p', mk_pred1T B); |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
49019
diff
changeset
|
487 |
|
49025 | 488 |
val xctrs = map2 (curry Term.list_comb) ctrs xss; |
489 |
val yctrs = map2 (curry Term.list_comb) ctrs yss; |
|
49032 | 490 |
|
49043 | 491 |
val xfs = map2 (curry Term.list_comb) fs xss; |
492 |
val xgs = map2 (curry Term.list_comb) gs xss; |
|
493 |
||
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
494 |
(* TODO: Eta-expension is for compatibility with the old datatype package (but it also provides |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
495 |
nicer names). Consider removing. *) |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
496 |
val eta_fs = map2 (fold_rev Term.lambda) xss xfs; |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
497 |
val eta_gs = map2 (fold_rev Term.lambda) xss xgs; |
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
498 |
|
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
499 |
val case_binding = |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
500 |
qualify false |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
501 |
(if Binding.is_empty raw_case_binding orelse |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
502 |
Binding.eq_name (raw_case_binding, standard_binding) then |
54493
5b34a5b93ec2
use type suffixes instead of prefixes for 'case', '(un)fold', '(co)rec'
blanchet
parents:
54491
diff
changeset
|
503 |
Binding.prefix_name (caseN ^ "_") fc_b |
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
504 |
else |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
505 |
raw_case_binding); |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
506 |
|
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
507 |
fun mk_case_disj xctr xf xs = |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
508 |
list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr), HOLogic.mk_eq (w, xf))); |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
509 |
|
53925 | 510 |
val case_rhs = fold_rev (fold_rev Term.lambda) [fs, [u]] |
69593 | 511 |
(Const (\<^const_name>\<open>The\<close>, (B --> HOLogic.boolT) --> B) $ |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
512 |
Term.lambda w (Library.foldr1 HOLogic.mk_disj (@{map 3} mk_case_disj xctrs xfs xss))); |
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
513 |
|
61101
7b915ca69af1
use open/close_target rather than Local_Theory.restore to get polymorphic definitions;
traytel
parents:
60822
diff
changeset
|
514 |
val ((raw_case, (_, raw_case_def)), (lthy, lthy_old)) = no_defs_lthy |
72154 | 515 |
|> Local_Theory.open_target |
54155 | 516 |
|> Local_Theory.define ((case_binding, NoSyn), |
59859 | 517 |
((Binding.concealed (Thm.def_binding case_binding), []), case_rhs)) |
61101
7b915ca69af1
use open/close_target rather than Local_Theory.restore to get polymorphic definitions;
traytel
parents:
60822
diff
changeset
|
518 |
||> `Local_Theory.close_target; |
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
519 |
|
61101
7b915ca69af1
use open/close_target rather than Local_Theory.restore to get polymorphic definitions;
traytel
parents:
60822
diff
changeset
|
520 |
val phi = Proof_Context.export_morphism lthy_old lthy; |
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
521 |
|
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
522 |
val case_def = Morphism.thm phi raw_case_def; |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
523 |
|
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
524 |
val case0 = Morphism.term phi raw_case; |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
525 |
val casex = mk_case As B case0; |
59266 | 526 |
val casexC = mk_case As C case0; |
59271 | 527 |
val casexBool = mk_case As HOLogic.boolT case0; |
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
528 |
|
49591
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49586
diff
changeset
|
529 |
fun mk_uu_eq () = HOLogic.mk_eq (u, u); |
49486 | 530 |
|
531 |
val exist_xs_u_eq_ctrs = |
|
532 |
map2 (fn xctr => fn xs => list_exists_free xs (HOLogic.mk_eq (u, xctr))) xctrs xss; |
|
49022 | 533 |
|
51743 | 534 |
val unique_disc_no_def = TrueI; (*arbitrary marker*) |
535 |
val alternate_disc_no_def = FalseE; (*arbitrary marker*) |
|
536 |
||
49486 | 537 |
fun alternate_disc_lhs get_udisc k = |
49116
3d520eec2746
allow pseudo-definition of is_Cons in terms of is_Nil (and similarly for other two-constructor datatypes)
blanchet
parents:
49114
diff
changeset
|
538 |
HOLogic.mk_not |
51790
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
539 |
(let val b = nth disc_bindings (k - 1) in |
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
540 |
if is_disc_binding_valid b then get_udisc b (k - 1) else nth exist_xs_u_eq_ctrs (k - 1) |
22517d04d20b
more intuitive syntax for equality-style discriminators of nullary constructors
blanchet
parents:
51787
diff
changeset
|
541 |
end); |
49116
3d520eec2746
allow pseudo-definition of is_Cons in terms of is_Nil (and similarly for other two-constructor datatypes)
blanchet
parents:
49114
diff
changeset
|
542 |
|
57094
589ec121ce1a
don't generate discriminators and selectors for 'datatype_new' unless the user asked for it
blanchet
parents:
57091
diff
changeset
|
543 |
val no_discs_sels = |
589ec121ce1a
don't generate discriminators and selectors for 'datatype_new' unless the user asked for it
blanchet
parents:
57091
diff
changeset
|
544 |
not discs_sels andalso |
589ec121ce1a
don't generate discriminators and selectors for 'datatype_new' unless the user asked for it
blanchet
parents:
57091
diff
changeset
|
545 |
forall (forall Binding.is_empty) (raw_disc_bindings :: raw_sel_bindingss) andalso |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
546 |
null sel_default_eqs; |
57094
589ec121ce1a
don't generate discriminators and selectors for 'datatype_new' unless the user asked for it
blanchet
parents:
57091
diff
changeset
|
547 |
|
61101
7b915ca69af1
use open/close_target rather than Local_Theory.restore to get polymorphic definitions;
traytel
parents:
60822
diff
changeset
|
548 |
val (all_sels_distinct, discs, selss, disc_defs, sel_defs, sel_defss, lthy) = |
52969
f2df0730f8ac
clarified option name (since case/fold/rec are also destructors)
blanchet
parents:
52968
diff
changeset
|
549 |
if no_discs_sels then |
61101
7b915ca69af1
use open/close_target rather than Local_Theory.restore to get polymorphic definitions;
traytel
parents:
60822
diff
changeset
|
550 |
(true, [], [], [], [], [], lthy) |
49278 | 551 |
else |
552 |
let |
|
57830
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
553 |
val all_sel_bindings = flat sel_bindingss; |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
554 |
val num_all_sel_bindings = length all_sel_bindings; |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
555 |
val uniq_sel_bindings = distinct Binding.eq_name all_sel_bindings; |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
556 |
val all_sels_distinct = (length uniq_sel_bindings = num_all_sel_bindings); |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
557 |
|
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
558 |
val sel_binding_index = |
57830
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
559 |
if all_sels_distinct then |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
560 |
1 upto num_all_sel_bindings |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
561 |
else |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
562 |
map (fn b => find_index (curry Binding.eq_name b) uniq_sel_bindings) all_sel_bindings; |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
563 |
|
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
564 |
val all_proto_sels = flat (@{map 3} (fn k => fn xs => map (pair k o pair xs)) ks xss xss); |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
565 |
val sel_infos = |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
566 |
AList.group (op =) (sel_binding_index ~~ all_proto_sels) |
59058
a78612c67ec0
renamed "pairself" to "apply2", in accordance to @{apply 2};
wenzelm
parents:
58998
diff
changeset
|
567 |
|> sort (int_ord o apply2 fst) |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
568 |
|> map snd |> curry (op ~~) uniq_sel_bindings; |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
569 |
val sel_bindings = map fst sel_infos; |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
570 |
|
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
571 |
val sel_defaults = |
57830
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
572 |
if null sel_default_eqs then |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
573 |
[] |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
574 |
else |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
575 |
let |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
576 |
val sel_Ts = map (curry (op -->) fcT o fastype_of o snd o snd o hd o snd) sel_infos; |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
577 |
val fake_lthy = |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
578 |
fake_local_theory_for_sel_defaults (sel_bindings ~~ sel_Ts) no_defs_lthy; |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
579 |
in |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
580 |
map (extract_sel_default fake_lthy o prep_term fake_lthy) sel_default_eqs |
2d0f0d6fdf3e
correctly resolve selector names in default value equations
blanchet
parents:
57633
diff
changeset
|
581 |
end; |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
582 |
|
53908 | 583 |
fun disc_free b = Free (Binding.name_of b, mk_pred1T fcT); |
49025 | 584 |
|
54634
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
585 |
fun disc_spec b exist_xs_u_eq_ctr = mk_Trueprop_eq (disc_free b $ u, exist_xs_u_eq_ctr); |
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
586 |
|
49500 | 587 |
fun alternate_disc k = |
588 |
Term.lambda u (alternate_disc_lhs (K o rapp u o disc_free) (3 - k)); |
|
49278 | 589 |
|
49280
52413dc96326
allow default values for selectors in low-level "wrap_data" command
blanchet
parents:
49278
diff
changeset
|
590 |
fun mk_sel_case_args b proto_sels T = |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
591 |
@{map 3} (fn Const (c, _) => fn Ts => fn k => |
49280
52413dc96326
allow default values for selectors in low-level "wrap_data" command
blanchet
parents:
49278
diff
changeset
|
592 |
(case AList.lookup (op =) proto_sels k of |
52413dc96326
allow default values for selectors in low-level "wrap_data" command
blanchet
parents:
49278
diff
changeset
|
593 |
NONE => |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
594 |
(case filter (curry (op =) (c, Binding.name_of b) o fst) sel_defaults of |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
595 |
[] => fold_rev (Term.lambda o curry Free Name.uu) Ts (mk_undefined T) |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
596 |
| [(_, t)] => t |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
597 |
| _ => error "Multiple default values for selector/constructor pair") |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
598 |
| SOME (xs, x) => fold_rev Term.lambda xs x)) ctrs ctr_Tss ks; |
49258
84f13469d7f0
allow same selector name for several constructors
blanchet
parents:
49257
diff
changeset
|
599 |
|
54634
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
600 |
fun sel_spec b proto_sels = |
49278 | 601 |
let |
602 |
val _ = |
|
603 |
(case duplicates (op =) (map fst proto_sels) of |
|
604 |
k :: _ => error ("Duplicate selector name " ^ quote (Binding.name_of b) ^ |
|
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
605 |
" for constructor " ^ quote (Syntax.string_of_term lthy (nth ctrs (k - 1)))) |
49278 | 606 |
| [] => ()) |
607 |
val T = |
|
608 |
(case distinct (op =) (map (fastype_of o snd o snd) proto_sels) of |
|
609 |
[T] => T |
|
610 |
| T :: T' :: _ => error ("Inconsistent range type for selector " ^ |
|
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
611 |
quote (Binding.name_of b) ^ ": " ^ quote (Syntax.string_of_typ lthy T) ^ |
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
612 |
" vs. " ^ quote (Syntax.string_of_typ lthy T'))); |
49278 | 613 |
in |
54634
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
614 |
mk_Trueprop_eq (Free (Binding.name_of b, fcT --> T) $ u, |
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
615 |
Term.list_comb (mk_case As T case0, mk_sel_case_args b proto_sels T) $ u) |
49278 | 616 |
end; |
49116
3d520eec2746
allow pseudo-definition of is_Cons in terms of is_Nil (and similarly for other two-constructor datatypes)
blanchet
parents:
49114
diff
changeset
|
617 |
|
49336 | 618 |
fun unflat_selss xs = unflat_lookup Binding.eq_name sel_bindings xs sel_bindingss; |
49258
84f13469d7f0
allow same selector name for several constructors
blanchet
parents:
49257
diff
changeset
|
619 |
|
49278 | 620 |
val (((raw_discs, raw_disc_defs), (raw_sels, raw_sel_defs)), (lthy', lthy)) = |
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
621 |
lthy |
72154 | 622 |
|> Local_Theory.open_target |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
623 |
|> apfst split_list o @{fold_map 3} (fn k => fn exist_xs_u_eq_ctr => fn b => |
54634
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
624 |
if Binding.is_empty b then |
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
625 |
if n = 1 then pair (Term.lambda u (mk_uu_eq ()), unique_disc_no_def) |
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
626 |
else pair (alternate_disc k, alternate_disc_no_def) |
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
627 |
else if Binding.eq_name (b, equal_binding) then |
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
628 |
pair (Term.lambda u exist_xs_u_eq_ctr, refl) |
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
629 |
else |
63180 | 630 |
Specification.definition (SOME (b, NONE, NoSyn)) [] [] |
63064
2f18172214c8
support 'assumes' in specifications, e.g. 'definition', 'inductive';
wenzelm
parents:
62326
diff
changeset
|
631 |
((Thm.def_binding b, []), disc_spec b exist_xs_u_eq_ctr) #>> apsnd snd) |
54634
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
632 |
ks exist_xs_u_eq_ctrs disc_bindings |
49278 | 633 |
||>> apfst split_list o fold_map (fn (b, proto_sels) => |
63180 | 634 |
Specification.definition (SOME (b, NONE, NoSyn)) [] [] |
63064
2f18172214c8
support 'assumes' in specifications, e.g. 'definition', 'inductive';
wenzelm
parents:
62326
diff
changeset
|
635 |
((Thm.def_binding b, []), sel_spec b proto_sels) #>> apsnd snd) sel_infos |
61101
7b915ca69af1
use open/close_target rather than Local_Theory.restore to get polymorphic definitions;
traytel
parents:
60822
diff
changeset
|
636 |
||> `Local_Theory.close_target; |
49022 | 637 |
|
49278 | 638 |
val phi = Proof_Context.export_morphism lthy lthy'; |
49025 | 639 |
|
49278 | 640 |
val disc_defs = map (Morphism.thm phi) raw_disc_defs; |
49281 | 641 |
val sel_defs = map (Morphism.thm phi) raw_sel_defs; |
642 |
val sel_defss = unflat_selss sel_defs; |
|
49278 | 643 |
|
644 |
val discs0 = map (Morphism.term phi) raw_discs; |
|
645 |
val selss0 = unflat_selss (map (Morphism.term phi) raw_sels); |
|
49028 | 646 |
|
49278 | 647 |
val discs = map (mk_disc_or_sel As) discs0; |
648 |
val selss = map (map (mk_disc_or_sel As)) selss0; |
|
649 |
in |
|
53917 | 650 |
(all_sels_distinct, discs, selss, disc_defs, sel_defs, sel_defss, lthy') |
49278 | 651 |
end; |
49025 | 652 |
|
49032 | 653 |
fun mk_imp_p Qs = Logic.list_implies (Qs, HOLogic.mk_Trueprop p); |
49029 | 654 |
|
49458 | 655 |
val exhaust_goal = |
55409
b74248961819
made 'ctr_sugar' more friendly to the 'datatype_realizer'
blanchet
parents:
55407
diff
changeset
|
656 |
let fun mk_prem xctr xs = fold_rev Logic.all xs (mk_imp_p [mk_Trueprop_eq (exh_y, xctr)]) in |
b74248961819
made 'ctr_sugar' more friendly to the 'datatype_realizer'
blanchet
parents:
55407
diff
changeset
|
657 |
fold_rev Logic.all [p, exh_y] (mk_imp_p (map2 mk_prem xctrs xss)) |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
49019
diff
changeset
|
658 |
end; |
49019 | 659 |
|
49484 | 660 |
val inject_goalss = |
49017 | 661 |
let |
49034
b77e1910af8a
make parallel list indexing possible for inject theorems
blanchet
parents:
49033
diff
changeset
|
662 |
fun mk_goal _ _ [] [] = [] |
49025 | 663 |
| mk_goal xctr yctr xs ys = |
49121 | 664 |
[fold_rev Logic.all (xs @ ys) (mk_Trueprop_eq (HOLogic.mk_eq (xctr, yctr), |
665 |
Library.foldr1 HOLogic.mk_conj (map2 (curry HOLogic.mk_eq) xs ys)))]; |
|
49017 | 666 |
in |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
667 |
@{map 4} mk_goal xctrs yctrs xss yss |
49017 | 668 |
end; |
669 |
||
49484 | 670 |
val half_distinct_goalss = |
49121 | 671 |
let |
49203 | 672 |
fun mk_goal ((xs, xc), (xs', xc')) = |
49121 | 673 |
fold_rev Logic.all (xs @ xs') |
49203 | 674 |
(HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq (xc, xc')))); |
49121 | 675 |
in |
49585
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
676 |
map (map mk_goal) (mk_half_pairss (`I (xss ~~ xctrs))) |
49121 | 677 |
end; |
49019 | 678 |
|
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
679 |
val goalss = [exhaust_goal] :: inject_goalss @ half_distinct_goalss; |
49019 | 680 |
|
60279
351536745704
took out unreliable 'blast' from tactic altogether
blanchet
parents:
60251
diff
changeset
|
681 |
fun after_qed ([exhaust_thm] :: thmss) lthy = |
49019 | 682 |
let |
62320 | 683 |
val ((((((((u, u'), (xss, xss')), fs), gs), h), v), p), _) = lthy |
61550
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
684 |
|> add_bindings |
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
685 |
|> yield_singleton (apfst (op ~~) oo mk_Frees' fc_b_name) fcT |
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
686 |
||>> mk_Freess' "x" ctr_Tss |
61272
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
687 |
||>> mk_Frees "f" case_Ts |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
688 |
||>> mk_Frees "g" case_Ts |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
689 |
||>> yield_singleton (mk_Frees "h") (B --> C) |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
690 |
||>> yield_singleton (mk_Frees (fc_b_name ^ "'")) fcT |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
691 |
||>> yield_singleton (mk_Frees "P") HOLogic.boolT; |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
692 |
|
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
693 |
val xfs = map2 (curry Term.list_comb) fs xss; |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
694 |
val xgs = map2 (curry Term.list_comb) gs xss; |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
695 |
|
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
696 |
val fcase = Term.list_comb (casex, fs); |
61550
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
697 |
|
61272
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
698 |
val ufcase = fcase $ u; |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
699 |
val vfcase = fcase $ v; |
61550
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
700 |
|
61272
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
701 |
val eta_fcase = Term.list_comb (casex, eta_fs); |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
702 |
val eta_gcase = Term.list_comb (casex, eta_gs); |
61550
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
703 |
|
61272
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
704 |
val eta_ufcase = eta_fcase $ u; |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
705 |
val eta_vgcase = eta_gcase $ v; |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
706 |
|
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
707 |
fun mk_uu_eq () = HOLogic.mk_eq (u, u); |
61550
0b39a1f26604
allow selectors and discriminators with same name as type
blanchet
parents:
61334
diff
changeset
|
708 |
|
61272
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
709 |
val uv_eq = mk_Trueprop_eq (u, v); |
f49644098959
restructure fresh variable generation to make exports more wellformed
traytel
parents:
61271
diff
changeset
|
710 |
|
57633 | 711 |
val ((inject_thms, inject_thmss), half_distinct_thmss) = chop n thmss |>> `flat; |
49438 | 712 |
|
60642
48dd1cefb4ae
simplified Thm.instantiate and derivatives: the LHS refers to non-certified variables -- this merely serves as index into already certified structures (or is ignored);
wenzelm
parents:
60279
diff
changeset
|
713 |
val rho_As = |
48dd1cefb4ae
simplified Thm.instantiate and derivatives: the LHS refers to non-certified variables -- this merely serves as index into already certified structures (or is ignored);
wenzelm
parents:
60279
diff
changeset
|
714 |
map (fn (T, U) => (dest_TVar T, Thm.ctyp_of lthy U)) |
48dd1cefb4ae
simplified Thm.instantiate and derivatives: the LHS refers to non-certified variables -- this merely serves as index into already certified structures (or is ignored);
wenzelm
parents:
60279
diff
changeset
|
715 |
(map Logic.varifyT_global As ~~ As); |
49486 | 716 |
|
717 |
fun inst_thm t thm = |
|
60801 | 718 |
Thm.instantiate' [] [SOME (Thm.cterm_of lthy t)] |
53210
7219c61796c0
simplify code (now that ctr_sugar uses the same type variables as fp_sugar)
blanchet
parents:
53040
diff
changeset
|
719 |
(Thm.instantiate (rho_As, []) (Drule.zero_var_indexes thm)); |
49486 | 720 |
|
721 |
val uexhaust_thm = inst_thm u exhaust_thm; |
|
49032 | 722 |
|
49300 | 723 |
val exhaust_cases = map base_name_of_ctr ctrs; |
724 |
||
49048
4e0f0f98be02
rationalized data structure for distinctness theorems
blanchet
parents:
49046
diff
changeset
|
725 |
val other_half_distinct_thmss = map (map (fn thm => thm RS not_sym)) half_distinct_thmss; |
4e0f0f98be02
rationalized data structure for distinctness theorems
blanchet
parents:
49046
diff
changeset
|
726 |
|
49486 | 727 |
val (distinct_thms, (distinct_thmsss', distinct_thmsss)) = |
49585
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
728 |
join_halves n half_distinct_thmss other_half_distinct_thmss ||> `transpose; |
49019 | 729 |
|
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
49019
diff
changeset
|
730 |
val nchotomy_thm = |
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
49019
diff
changeset
|
731 |
let |
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
49019
diff
changeset
|
732 |
val goal = |
49486 | 733 |
HOLogic.mk_Trueprop (HOLogic.mk_all (fst u', snd u', |
734 |
Library.foldr1 HOLogic.mk_disj exist_xs_u_eq_ctrs)); |
|
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
49019
diff
changeset
|
735 |
in |
60728 | 736 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => |
737 |
mk_nchotomy_tac ctxt n exhaust_thm) |
|
70494 | 738 |
|> Thm.close_derivation \<^here> |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
49019
diff
changeset
|
739 |
end; |
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
49019
diff
changeset
|
740 |
|
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
741 |
val case_thms = |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
742 |
let |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
743 |
val goals = |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
744 |
@{map 3} (fn xctr => fn xf => fn xs => |
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
745 |
fold_rev Logic.all (fs @ xs) (mk_Trueprop_eq (fcase $ xctr, xf))) xctrs xfs xss; |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
746 |
in |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
747 |
@{map 4} (fn k => fn goal => fn injects => fn distinctss => |
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
748 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} => |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
749 |
mk_case_tac ctxt n k case_def injects distinctss) |
70494 | 750 |
|> Thm.close_derivation \<^here>) |
52968
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
751 |
ks goals inject_thmss distinct_thmsss |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
752 |
end; |
2b430bbb5a1a
define case constant from other 'free constructor' axioms
blanchet
parents:
52965
diff
changeset
|
753 |
|
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
754 |
val (case_cong_thm, case_cong_weak_thm) = |
53917 | 755 |
let |
756 |
fun mk_prem xctr xs xf xg = |
|
757 |
fold_rev Logic.all xs (Logic.mk_implies (mk_Trueprop_eq (v, xctr), |
|
758 |
mk_Trueprop_eq (xf, xg))); |
|
759 |
||
760 |
val goal = |
|
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
761 |
Logic.list_implies (uv_eq :: @{map 4} mk_prem xctrs xss xfs xgs, |
53917 | 762 |
mk_Trueprop_eq (eta_ufcase, eta_vgcase)); |
763 |
val weak_goal = Logic.mk_implies (uv_eq, mk_Trueprop_eq (ufcase, vfcase)); |
|
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
764 |
val vars = Variable.add_free_names lthy goal []; |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
765 |
val weak_vars = Variable.add_free_names lthy weak_goal []; |
53917 | 766 |
in |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
767 |
(Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => |
61271 | 768 |
mk_case_cong_tac ctxt uexhaust_thm case_thms), |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
769 |
Goal.prove_sorry lthy weak_vars [] weak_goal (fn {context = ctxt, prems = _} => |
60728 | 770 |
etac ctxt arg_cong 1)) |
70494 | 771 |
|> apply2 (Thm.close_derivation \<^here>) |
53917 | 772 |
end; |
773 |
||
774 |
val split_lhs = q $ ufcase; |
|
775 |
||
776 |
fun mk_split_conjunct xctr xs f_xs = |
|
777 |
list_all_free xs (HOLogic.mk_imp (HOLogic.mk_eq (u, xctr), q $ f_xs)); |
|
778 |
fun mk_split_disjunct xctr xs f_xs = |
|
779 |
list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr), |
|
780 |
HOLogic.mk_not (q $ f_xs))); |
|
781 |
||
782 |
fun mk_split_goal xctrs xss xfs = |
|
783 |
mk_Trueprop_eq (split_lhs, Library.foldr1 HOLogic.mk_conj |
|
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
784 |
(@{map 3} mk_split_conjunct xctrs xss xfs)); |
53917 | 785 |
fun mk_split_asm_goal xctrs xss xfs = |
786 |
mk_Trueprop_eq (split_lhs, HOLogic.mk_not (Library.foldr1 HOLogic.mk_disj |
|
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
787 |
(@{map 3} mk_split_disjunct xctrs xss xfs))); |
53917 | 788 |
|
789 |
fun prove_split selss goal = |
|
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
790 |
Variable.add_free_names lthy goal [] |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
791 |
|> (fn vars => Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => |
64430
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
792 |
mk_split_tac ctxt uexhaust_thm case_thms selss inject_thmss distinct_thmsss)) |
70494 | 793 |
|> Thm.close_derivation \<^here>; |
53917 | 794 |
|
795 |
fun prove_split_asm asm_goal split_thm = |
|
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
796 |
Variable.add_free_names lthy asm_goal [] |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
797 |
|> (fn vars => Goal.prove_sorry lthy vars [] asm_goal (fn {context = ctxt, ...} => |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
798 |
mk_split_asm_tac ctxt split_thm)) |
70494 | 799 |
|> Thm.close_derivation \<^here>; |
53917 | 800 |
|
801 |
val (split_thm, split_asm_thm) = |
|
802 |
let |
|
803 |
val goal = mk_split_goal xctrs xss xfs; |
|
804 |
val asm_goal = mk_split_asm_goal xctrs xss xfs; |
|
805 |
||
806 |
val thm = prove_split (replicate n []) goal; |
|
807 |
val asm_thm = prove_split_asm asm_goal thm; |
|
808 |
in |
|
809 |
(thm, asm_thm) |
|
810 |
end; |
|
811 |
||
64430
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
812 |
val (sel_defs, all_sel_thms, sel_thmss, nontriv_disc_defs, disc_thmss, nontriv_disc_thmss, |
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
813 |
discI_thms, nontriv_discI_thms, distinct_disc_thms, distinct_disc_thmsss, |
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
814 |
exhaust_disc_thms, exhaust_sel_thms, all_collapse_thms, safe_collapse_thms, |
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
815 |
expand_thms, split_sel_thms, split_sel_asm_thms, case_eq_if_thms, disc_eq_case_thms) = |
52969
f2df0730f8ac
clarified option name (since case/fold/rec are also destructors)
blanchet
parents:
52968
diff
changeset
|
816 |
if no_discs_sels then |
64430
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
817 |
([], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], []) |
49116
3d520eec2746
allow pseudo-definition of is_Cons in terms of is_Nil (and similarly for other two-constructor datatypes)
blanchet
parents:
49114
diff
changeset
|
818 |
else |
3d520eec2746
allow pseudo-definition of is_Cons in terms of is_Nil (and similarly for other two-constructor datatypes)
blanchet
parents:
49114
diff
changeset
|
819 |
let |
53917 | 820 |
val udiscs = map (rapp u) discs; |
821 |
val uselss = map (map (rapp u)) selss; |
|
822 |
val usel_ctrs = map2 (curry Term.list_comb) ctrs uselss; |
|
823 |
val usel_fs = map2 (curry Term.list_comb) fs uselss; |
|
824 |
||
825 |
val vdiscs = map (rapp v) discs; |
|
826 |
val vselss = map (map (rapp v)) selss; |
|
827 |
||
49364
838b5e8ede73
allow default values to refer to selector arguments -- this is useful, e.g. for tllist: ttl (TNil x) = TNil x (example by Andreas Lochbihler)
blanchet
parents:
49336
diff
changeset
|
828 |
fun make_sel_thm xs' case_thm sel_def = |
59647
c6f413b660cf
clarified Drule.gen_all: observe context more carefully;
wenzelm
parents:
59621
diff
changeset
|
829 |
zero_var_indexes |
60822 | 830 |
(Variable.gen_all lthy |
59647
c6f413b660cf
clarified Drule.gen_all: observe context more carefully;
wenzelm
parents:
59621
diff
changeset
|
831 |
(Drule.rename_bvars' |
c6f413b660cf
clarified Drule.gen_all: observe context more carefully;
wenzelm
parents:
59621
diff
changeset
|
832 |
(map (SOME o fst) xs') |
c6f413b660cf
clarified Drule.gen_all: observe context more carefully;
wenzelm
parents:
59621
diff
changeset
|
833 |
(Drule.forall_intr_vars (case_thm RS (sel_def RS trans))))); |
49281 | 834 |
|
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
835 |
val sel_thmss = @{map 3} (map oo make_sel_thm) xss' case_thms sel_defss; |
53704 | 836 |
|
49281 | 837 |
fun has_undefined_rhs thm = |
59582 | 838 |
(case snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of thm))) of |
69593 | 839 |
Const (\<^const_name>\<open>undefined\<close>, _) => true |
49281 | 840 |
| _ => false); |
841 |
||
842 |
val all_sel_thms = |
|
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
843 |
(if all_sels_distinct andalso null sel_default_eqs then |
49285
036b833b99aa
removed wrong "transpose" and ensure "sel" theorems are put in the right order (grouped per selector, in the order in which the selectors appear)
blanchet
parents:
49281
diff
changeset
|
844 |
flat sel_thmss |
036b833b99aa
removed wrong "transpose" and ensure "sel" theorems are put in the right order (grouped per selector, in the order in which the selectors appear)
blanchet
parents:
49281
diff
changeset
|
845 |
else |
49364
838b5e8ede73
allow default values to refer to selector arguments -- this is useful, e.g. for tllist: ttl (TNil x) = TNil x (example by Andreas Lochbihler)
blanchet
parents:
49336
diff
changeset
|
846 |
map_product (fn s => fn (xs', c) => make_sel_thm xs' c s) sel_defs |
838b5e8ede73
allow default values to refer to selector arguments -- this is useful, e.g. for tllist: ttl (TNil x) = TNil x (example by Andreas Lochbihler)
blanchet
parents:
49336
diff
changeset
|
847 |
(xss' ~~ case_thms)) |
49285
036b833b99aa
removed wrong "transpose" and ensure "sel" theorems are put in the right order (grouped per selector, in the order in which the selectors appear)
blanchet
parents:
49281
diff
changeset
|
848 |
|> filter_out has_undefined_rhs; |
49278 | 849 |
|
850 |
fun mk_unique_disc_def () = |
|
851 |
let |
|
852 |
val m = the_single ms; |
|
49591
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49586
diff
changeset
|
853 |
val goal = mk_Trueprop_eq (mk_uu_eq (), the_single exist_xs_u_eq_ctrs); |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
854 |
val vars = Variable.add_free_names lthy goal []; |
49278 | 855 |
in |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
856 |
Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => |
60728 | 857 |
mk_unique_disc_def_tac ctxt m uexhaust_thm) |
70494 | 858 |
|> Thm.close_derivation \<^here> |
49278 | 859 |
end; |
860 |
||
861 |
fun mk_alternate_disc_def k = |
|
862 |
let |
|
863 |
val goal = |
|
49486 | 864 |
mk_Trueprop_eq (alternate_disc_lhs (K (nth udiscs)) (3 - k), |
865 |
nth exist_xs_u_eq_ctrs (k - 1)); |
|
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
866 |
val vars = Variable.add_free_names lthy goal []; |
49278 | 867 |
in |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
868 |
Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => |
54634
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
869 |
mk_alternate_disc_def_tac ctxt k (nth disc_defs (2 - k)) |
49486 | 870 |
(nth distinct_thms (2 - k)) uexhaust_thm) |
70494 | 871 |
|> Thm.close_derivation \<^here> |
49278 | 872 |
end; |
49028 | 873 |
|
49278 | 874 |
val has_alternate_disc_def = |
875 |
exists (fn def => Thm.eq_thm_prop (def, alternate_disc_no_def)) disc_defs; |
|
876 |
||
63313
0c956a9a0ac0
avoid runtime warning with discriminators due to 'Code.del_eqn'
blanchet
parents:
63239
diff
changeset
|
877 |
val nontriv_disc_defs = disc_defs |
63853 | 878 |
|> filter_out (member Thm.eq_thm_prop [unique_disc_no_def, alternate_disc_no_def, |
879 |
refl]); |
|
63313
0c956a9a0ac0
avoid runtime warning with discriminators due to 'Code.del_eqn'
blanchet
parents:
63239
diff
changeset
|
880 |
|
49278 | 881 |
val disc_defs' = |
882 |
map2 (fn k => fn def => |
|
883 |
if Thm.eq_thm_prop (def, unique_disc_no_def) then mk_unique_disc_def () |
|
884 |
else if Thm.eq_thm_prop (def, alternate_disc_no_def) then mk_alternate_disc_def k |
|
54634
366297517091
reverted 141cb34744de and e78e7df36690 -- better provide nicer "eta-expanded" definitions for discriminators and selectors, since users might want to unfold them
blanchet
parents:
54626
diff
changeset
|
885 |
else def) ks disc_defs; |
49278 | 886 |
|
887 |
val discD_thms = map (fn def => def RS iffD1) disc_defs'; |
|
888 |
val discI_thms = |
|
889 |
map2 (fn m => fn def => funpow m (fn thm => exI RS thm) (def RS iffD2)) ms |
|
890 |
disc_defs'; |
|
891 |
val not_discI_thms = |
|
892 |
map2 (fn m => fn def => funpow m (fn thm => allI RS thm) |
|
49504
df9b897fb254
renamed "iter"/"coiter" to "fold"/"unfold" (cf. Wadler)
blanchet
parents:
49500
diff
changeset
|
893 |
(unfold_thms lthy @{thms not_ex} (def RS @{thm ssubst[of _ _ Not]}))) |
49278 | 894 |
ms disc_defs'; |
895 |
||
896 |
val (disc_thmss', disc_thmss) = |
|
897 |
let |
|
898 |
fun mk_thm discI _ [] = refl RS discI |
|
899 |
| mk_thm _ not_discI [distinct] = distinct RS not_discI; |
|
900 |
fun mk_thms discI not_discI distinctss = map (mk_thm discI not_discI) distinctss; |
|
901 |
in |
|
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
902 |
@{map 3} mk_thms discI_thms not_discI_thms distinct_thmsss' |> `transpose |
49278 | 903 |
end; |
904 |
||
55464 | 905 |
val nontriv_disc_thmss = |
906 |
map2 (fn b => if is_disc_binding_valid b then I else K []) disc_bindings disc_thmss; |
|
53704 | 907 |
|
62326
3cf7a067599c
allow predicator instead of map function in 'primrec'
blanchet
parents:
62322
diff
changeset
|
908 |
fun is_discI_triv b = |
53704 | 909 |
(n = 1 andalso Binding.is_empty b) orelse Binding.eq_name (b, equal_binding); |
910 |
||
911 |
val nontriv_discI_thms = |
|
62326
3cf7a067599c
allow predicator instead of map function in 'primrec'
blanchet
parents:
62322
diff
changeset
|
912 |
flat (map2 (fn b => if is_discI_triv b then K [] else single) disc_bindings |
53704 | 913 |
discI_thms); |
49028 | 914 |
|
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
915 |
val (distinct_disc_thms, (distinct_disc_thmsss', distinct_disc_thmsss)) = |
49486 | 916 |
let |
917 |
fun mk_goal [] = [] |
|
918 |
| mk_goal [((_, udisc), (_, udisc'))] = |
|
919 |
[Logic.all u (Logic.mk_implies (HOLogic.mk_Trueprop udisc, |
|
920 |
HOLogic.mk_Trueprop (HOLogic.mk_not udisc')))]; |
|
921 |
||
49667
44d85dc8ca08
use Thm.close_derivation in theorems proved using Skip_Proof.prove; tuned signature;
traytel
parents:
49633
diff
changeset
|
922 |
fun prove tac goal = |
60728 | 923 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => tac ctxt) |
70494 | 924 |
|> Thm.close_derivation \<^here>; |
49486 | 925 |
|
49585
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
926 |
val half_pairss = mk_half_pairss (`I (ms ~~ discD_thms ~~ udiscs)); |
49486 | 927 |
|
928 |
val half_goalss = map mk_goal half_pairss; |
|
929 |
val half_thmss = |
|
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
930 |
@{map 3} (fn [] => K (K []) | [goal] => fn [(((m, discD), _), _)] => |
60728 | 931 |
fn disc_thm => [prove (fn ctxt => |
932 |
mk_half_distinct_disc_tac ctxt m discD disc_thm) goal]) |
|
49486 | 933 |
half_goalss half_pairss (flat disc_thmss'); |
49278 | 934 |
|
49486 | 935 |
val other_half_goalss = map (mk_goal o map swap) half_pairss; |
936 |
val other_half_thmss = |
|
60728 | 937 |
map2 (map2 (fn thm => prove (fn ctxt => |
938 |
mk_other_half_distinct_disc_tac ctxt thm))) half_thmss |
|
49486 | 939 |
other_half_goalss; |
940 |
in |
|
49585
5c4a12550491
generate high-level "maps", "sets", and "rels" properties
blanchet
parents:
49536
diff
changeset
|
941 |
join_halves n half_thmss other_half_thmss ||> `transpose |
49486 | 942 |
|>> has_alternate_disc_def ? K [] |
943 |
end; |
|
49278 | 944 |
|
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
945 |
val exhaust_disc_thm = |
49486 | 946 |
let |
947 |
fun mk_prem udisc = mk_imp_p [HOLogic.mk_Trueprop udisc]; |
|
948 |
val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem udiscs)); |
|
949 |
in |
|
60728 | 950 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => |
951 |
mk_exhaust_disc_tac ctxt n exhaust_thm discI_thms) |
|
70494 | 952 |
|> Thm.close_derivation \<^here> |
49486 | 953 |
end; |
49028 | 954 |
|
53740 | 955 |
val (safe_collapse_thms, all_collapse_thms) = |
49486 | 956 |
let |
54008
b15cfc2864de
refactoring -- splitting between constructor sugar dependencies and true BNF dependencies
blanchet
parents:
54007
diff
changeset
|
957 |
fun mk_goal m udisc usel_ctr = |
49486 | 958 |
let |
959 |
val prem = HOLogic.mk_Trueprop udisc; |
|
53916 | 960 |
val concl = mk_Trueprop_eq ((usel_ctr, u) |> m = 0 ? swap); |
49486 | 961 |
in |
53740 | 962 |
(prem aconv concl, Logic.all u (Logic.mk_implies (prem, concl))) |
49486 | 963 |
end; |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
964 |
val (trivs, goals) = @{map 3} mk_goal ms udiscs usel_ctrs |> split_list; |
53740 | 965 |
val thms = |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
966 |
@{map 5} (fn m => fn discD => fn sel_thms => fn triv => fn goal => |
53740 | 967 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} => |
58963
26bf09b95dda
proper context for assume_tac (atac remains as fall-back without context);
wenzelm
parents:
58685
diff
changeset
|
968 |
mk_collapse_tac ctxt m discD sel_thms ORELSE HEADGOAL (assume_tac ctxt)) |
70494 | 969 |
|> Thm.close_derivation \<^here> |
53740 | 970 |
|> not triv ? perhaps (try (fn thm => refl RS thm))) |
971 |
ms discD_thms sel_thmss trivs goals; |
|
49486 | 972 |
in |
53740 | 973 |
(map_filter (fn (true, _) => NONE | (false, thm) => SOME thm) (trivs ~~ thms), |
974 |
thms) |
|
49486 | 975 |
end; |
49025 | 976 |
|
53916 | 977 |
val swapped_all_collapse_thms = |
978 |
map2 (fn m => fn thm => if m = 0 then thm else thm RS sym) ms all_collapse_thms; |
|
979 |
||
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
980 |
val exhaust_sel_thm = |
53916 | 981 |
let |
982 |
fun mk_prem usel_ctr = mk_imp_p [mk_Trueprop_eq (u, usel_ctr)]; |
|
983 |
val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem usel_ctrs)); |
|
984 |
in |
|
60728 | 985 |
Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => |
986 |
mk_exhaust_sel_tac ctxt n exhaust_disc_thm swapped_all_collapse_thms) |
|
70494 | 987 |
|> Thm.close_derivation \<^here> |
53916 | 988 |
end; |
989 |
||
53919 | 990 |
val expand_thm = |
49486 | 991 |
let |
992 |
fun mk_prems k udisc usels vdisc vsels = |
|
993 |
(if k = n then [] else [mk_Trueprop_eq (udisc, vdisc)]) @ |
|
994 |
(if null usels then |
|
995 |
[] |
|
996 |
else |
|
997 |
[Logic.list_implies |
|
998 |
(if n = 1 then [] else map HOLogic.mk_Trueprop [udisc, vdisc], |
|
999 |
HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj |
|
1000 |
(map2 (curry HOLogic.mk_eq) usels vsels)))]); |
|
1001 |
||
49591
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49586
diff
changeset
|
1002 |
val goal = |
91b228e26348
generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents:
49586
diff
changeset
|
1003 |
Library.foldr Logic.list_implies |
58634
9f10d82e8188
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
wenzelm
parents:
58335
diff
changeset
|
1004 |
(@{map 5} mk_prems ks udiscs uselss vdiscs vselss, uv_eq); |
49486 | 1005 |
val uncollapse_thms = |
53740 | 1006 |
map2 (fn thm => fn [] => thm | _ => thm RS sym) all_collapse_thms uselss; |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1007 |
val vars = Variable.add_free_names lthy goal []; |
49486 | 1008 |
in |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1009 |
Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, prems = _} => |
61271 | 1010 |
mk_expand_tac ctxt n ms (inst_thm u exhaust_disc_thm) |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
1011 |
(inst_thm v exhaust_disc_thm) uncollapse_thms distinct_disc_thmsss |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
1012 |
distinct_disc_thmsss') |
70494 | 1013 |
|> Thm.close_derivation \<^here> |
49486 | 1014 |
end; |
49278 | 1015 |
|
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
1016 |
val (split_sel_thm, split_sel_asm_thm) = |
53917 | 1017 |
let |
1018 |
val zss = map (K []) xss; |
|
1019 |
val goal = mk_split_goal usel_ctrs zss usel_fs; |
|
1020 |
val asm_goal = mk_split_asm_goal usel_ctrs zss usel_fs; |
|
1021 |
||
1022 |
val thm = prove_split sel_thmss goal; |
|
1023 |
val asm_thm = prove_split_asm asm_goal thm; |
|
1024 |
in |
|
1025 |
(thm, asm_thm) |
|
1026 |
end; |
|
1027 |
||
54491 | 1028 |
val case_eq_if_thm = |
49486 | 1029 |
let |
53917 | 1030 |
val goal = mk_Trueprop_eq (ufcase, mk_IfN B udiscs usel_fs); |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1031 |
val vars = Variable.add_free_names lthy goal []; |
49486 | 1032 |
in |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1033 |
Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => |
54491 | 1034 |
mk_case_eq_if_tac ctxt n uexhaust_thm case_thms disc_thmss' sel_thmss) |
70494 | 1035 |
|> Thm.close_derivation \<^here> |
49486 | 1036 |
end; |
59271 | 1037 |
|
1038 |
val disc_eq_case_thms = |
|
1039 |
let |
|
69597 | 1040 |
fun const_of_bool b = if b then \<^const>\<open>True\<close> else \<^const>\<open>False\<close>; |
59271 | 1041 |
fun mk_case_args n = map_index (fn (k, argTs) => |
59272 | 1042 |
fold_rev Term.absdummy argTs (const_of_bool (n = k))) ctr_Tss; |
59271 | 1043 |
val goals = map_index (fn (n, udisc) => |
1044 |
mk_Trueprop_eq (udisc, list_comb (casexBool, mk_case_args n) $ u)) udiscs; |
|
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1045 |
val goal = Logic.mk_conjunction_balanced goals; |
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1046 |
val vars = Variable.add_free_names lthy goal []; |
59271 | 1047 |
in |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1048 |
Goal.prove_sorry lthy vars [] goal |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59582
diff
changeset
|
1049 |
(fn {context = ctxt, ...} => mk_disc_eq_case_tac ctxt (Thm.cterm_of ctxt u) |
59271 | 1050 |
exhaust_thm (flat nontriv_disc_thmss) distinct_thms case_thms) |
70494 | 1051 |
|> Thm.close_derivation \<^here> |
59271 | 1052 |
|> Conjunction.elim_balanced (length goals) |
1053 |
end; |
|
49116
3d520eec2746
allow pseudo-definition of is_Cons in terms of is_Nil (and similarly for other two-constructor datatypes)
blanchet
parents:
49114
diff
changeset
|
1054 |
in |
64430
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
1055 |
(sel_defs, all_sel_thms, sel_thmss, nontriv_disc_defs, disc_thmss, nontriv_disc_thmss, |
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
1056 |
discI_thms, nontriv_discI_thms, distinct_disc_thms, distinct_disc_thmsss, |
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
1057 |
[exhaust_disc_thm], [exhaust_sel_thm], all_collapse_thms, safe_collapse_thms, |
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
1058 |
[expand_thm], [split_sel_thm], [split_sel_asm_thm], [case_eq_if_thm], |
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
1059 |
disc_eq_case_thms) |
49116
3d520eec2746
allow pseudo-definition of is_Cons in terms of is_Nil (and similarly for other two-constructor datatypes)
blanchet
parents:
49114
diff
changeset
|
1060 |
end; |
49025 | 1061 |
|
59266 | 1062 |
val case_distrib_thm = |
1063 |
let |
|
1064 |
val args = @{map 2} (fn f => fn argTs => |
|
1065 |
let val (args, _) = mk_Frees "x" argTs lthy in |
|
1066 |
fold_rev Term.lambda args (h $ list_comb (f, args)) |
|
1067 |
end) fs ctr_Tss; |
|
1068 |
val goal = mk_Trueprop_eq (h $ ufcase, list_comb (casexC, args) $ u); |
|
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1069 |
val vars = Variable.add_free_names lthy goal []; |
59266 | 1070 |
in |
61334
8d40ddaa427f
collect the names from goals in favor of fragile exports
traytel
parents:
61301
diff
changeset
|
1071 |
Goal.prove_sorry lthy vars [] goal (fn {context = ctxt, ...} => |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59582
diff
changeset
|
1072 |
mk_case_distrib_tac ctxt (Thm.cterm_of ctxt u) exhaust_thm case_thms) |
70494 | 1073 |
|> Thm.close_derivation \<^here> |
59266 | 1074 |
end; |
1075 |
||
49437 | 1076 |
val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases)); |
53908 | 1077 |
val cases_type_attr = Attrib.internal (K (Induct.cases_type fcT_name)); |
49300 | 1078 |
|
55464 | 1079 |
val nontriv_disc_eq_thmss = |
1080 |
map (map (fn th => th RS @{thm eq_False[THEN iffD2]} |
|
1081 |
handle THM _ => th RS @{thm eq_True[THEN iffD2]})) nontriv_disc_thmss; |
|
1082 |
||
54151 | 1083 |
val anonymous_notes = |
1084 |
[(map (fn th => th RS notE) distinct_thms, safe_elim_attrs), |
|
66251
cd935b7cb3fb
proper concept of code declaration wrt. atomicity and Isar declarations
haftmann
parents:
64430
diff
changeset
|
1085 |
(flat nontriv_disc_eq_thmss, nitpicksimp_attrs)] |
54151 | 1086 |
|> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); |
1087 |
||
49052 | 1088 |
val notes = |
66251
cd935b7cb3fb
proper concept of code declaration wrt. atomicity and Isar declarations
haftmann
parents:
64430
diff
changeset
|
1089 |
[(caseN, case_thms, nitpicksimp_attrs @ simp_attrs), |
49594
55e798614c45
tweaked theorem names (in particular, dropped s's)
blanchet
parents:
49591
diff
changeset
|
1090 |
(case_congN, [case_cong_thm], []), |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
1091 |
(case_cong_weak_thmsN, [case_cong_weak_thm], cong_attrs), |
59266 | 1092 |
(case_distribN, [case_distrib_thm], []), |
54491 | 1093 |
(case_eq_ifN, case_eq_if_thms, []), |
58151
414deb2ef328
take out 'x = C' of the simplifier for unit types
blanchet
parents:
58116
diff
changeset
|
1094 |
(collapseN, safe_collapse_thms, if ms = [0] then [] else simp_attrs), |
55464 | 1095 |
(discN, flat nontriv_disc_thmss, simp_attrs), |
59272 | 1096 |
(disc_eq_caseN, disc_eq_case_thms, []), |
53700 | 1097 |
(discIN, nontriv_discI_thms, []), |
54145
297d1c603999
make sure that registered code equations are actually equations
blanchet
parents:
54008
diff
changeset
|
1098 |
(distinctN, distinct_thms, simp_attrs @ inductsimp_attrs), |
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
1099 |
(distinct_discN, distinct_disc_thms, dest_attrs), |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
1100 |
(exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]), |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
1101 |
(exhaust_discN, exhaust_disc_thms, [exhaust_case_names_attr]), |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
1102 |
(exhaust_selN, exhaust_sel_thms, [exhaust_case_names_attr]), |
49486 | 1103 |
(expandN, expand_thms, []), |
54145
297d1c603999
make sure that registered code equations are actually equations
blanchet
parents:
54008
diff
changeset
|
1104 |
(injectN, inject_thms, iff_attrs @ inductsimp_attrs), |
49300 | 1105 |
(nchotomyN, [nchotomy_thm], []), |
66251
cd935b7cb3fb
proper concept of code declaration wrt. atomicity and Isar declarations
haftmann
parents:
64430
diff
changeset
|
1106 |
(selN, all_sel_thms, nitpicksimp_attrs @ simp_attrs), |
57985 | 1107 |
(splitN, [split_thm], []), |
1108 |
(split_asmN, [split_asm_thm], []), |
|
57983
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
1109 |
(split_selN, split_sel_thms, []), |
6edc3529bb4e
reordered some (co)datatype property names for more consistency
blanchet
parents:
57882
diff
changeset
|
1110 |
(split_sel_asmN, split_sel_asm_thms, []), |
57985 | 1111 |
(split_selsN, split_sel_thms @ split_sel_asm_thms, []), |
1112 |
(splitsN, [split_thm, split_asm_thm], [])] |
|
49300 | 1113 |
|> filter_out (null o #2) |
1114 |
|> map (fn (thmN, thms, attrs) => |
|
49633 | 1115 |
((qualify true (Binding.name thmN), attrs), [(thms, [])])); |
49300 | 1116 |
|
64430
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
1117 |
val (noted, lthy') = lthy |
71214
5727bcc3c47c
proper spec_rule name via naming/binding/Morphism.binding;
wenzelm
parents:
71179
diff
changeset
|
1118 |
|> Spec_Rules.add Binding.empty Spec_Rules.equational [casex] case_thms |
5727bcc3c47c
proper spec_rule name via naming/binding/Morphism.binding;
wenzelm
parents:
71179
diff
changeset
|
1119 |
|> fold (uncurry (Spec_Rules.add Binding.empty Spec_Rules.equational)) |
57629
e88b5f59cade
use the noted theorem whenever possible, because it has a named derivation (leading to cleaner proof terms)
blanchet
parents:
57260
diff
changeset
|
1120 |
(AList.group (eq_list (op aconv)) (map (`(single o lhs_head_of)) all_sel_thms)) |
71214
5727bcc3c47c
proper spec_rule name via naming/binding/Morphism.binding;
wenzelm
parents:
71179
diff
changeset
|
1121 |
|> fold (uncurry (Spec_Rules.add Binding.empty Spec_Rules.equational)) |
57629
e88b5f59cade
use the noted theorem whenever possible, because it has a named derivation (leading to cleaner proof terms)
blanchet
parents:
57260
diff
changeset
|
1122 |
(filter_out (null o snd) (map single discs ~~ nontriv_disc_eq_thmss)) |
e88b5f59cade
use the noted theorem whenever possible, because it has a named derivation (leading to cleaner proof terms)
blanchet
parents:
57260
diff
changeset
|
1123 |
|> Local_Theory.declaration {syntax = false, pervasive = true} |
58335
a5a3b576fcfb
generate 'code' attribute only if 'code' plugin is enabled
blanchet
parents:
58317
diff
changeset
|
1124 |
(fn phi => Case_Translation.register |
a5a3b576fcfb
generate 'code' attribute only if 'code' plugin is enabled
blanchet
parents:
58317
diff
changeset
|
1125 |
(Morphism.term phi casex) (map (Morphism.term phi) ctrs)) |
58191 | 1126 |
|> plugins code_plugin ? |
66251
cd935b7cb3fb
proper concept of code declaration wrt. atomicity and Isar declarations
haftmann
parents:
64430
diff
changeset
|
1127 |
(Code.declare_default_eqns (map (rpair true) (flat nontriv_disc_eq_thmss @ case_thms @ all_sel_thms)) |
cd935b7cb3fb
proper concept of code declaration wrt. atomicity and Isar declarations
haftmann
parents:
64430
diff
changeset
|
1128 |
#> Local_Theory.declaration {syntax = false, pervasive = false} |
64430
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
1129 |
(fn phi => Context.mapping |
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
1130 |
(add_ctr_code fcT_name (map (Morphism.typ phi) As) |
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
1131 |
(map (dest_Const o Morphism.term phi) ctrs) (Morphism.fact phi inject_thms) |
1d85ac286c72
avoid code generator warnings when deleting equations in BNF commands (e.g., datatype) in locales with assumptions and similar
blanchet
parents:
63853
diff
changeset
|
1132 |
(Morphism.fact phi distinct_thms) (Morphism.fact phi case_thms)) |
66251
cd935b7cb3fb
proper concept of code declaration wrt. atomicity and Isar declarations
haftmann
parents:
64430
diff
changeset
|
1133 |
I)) |
57633 | 1134 |
|> Local_Theory.notes (anonymous_notes @ notes) |
58317 | 1135 |
(* for "datatype_realizer.ML": *) |
57633 | 1136 |
|>> name_noted_thms fcT_name exhaustN; |
57629
e88b5f59cade
use the noted theorem whenever possible, because it has a named derivation (leading to cleaner proof terms)
blanchet
parents:
57260
diff
changeset
|
1137 |
|
53867
8ad44ecc0d15
keep a database of free constructor type information
blanchet
parents:
53864
diff
changeset
|
1138 |
val ctr_sugar = |
58675 | 1139 |
{kind = kind, T = fcT, ctrs = ctrs, casex = casex, discs = discs, selss = selss, |
1140 |
exhaust = exhaust_thm, nchotomy = nchotomy_thm, injects = inject_thms, |
|
1141 |
distincts = distinct_thms, case_thms = case_thms, case_cong = case_cong_thm, |
|
59267 | 1142 |
case_cong_weak = case_cong_weak_thm, case_distribs = [case_distrib_thm], |
63313
0c956a9a0ac0
avoid runtime warning with discriminators due to 'Code.del_eqn'
blanchet
parents:
63239
diff
changeset
|
1143 |
split = split_thm, split_asm = split_asm_thm, disc_defs = nontriv_disc_defs, |
59271 | 1144 |
disc_thmss = disc_thmss, discIs = discI_thms, disc_eq_cases = disc_eq_case_thms, |
1145 |
sel_defs = sel_defs, sel_thmss = sel_thmss, distinct_discsss = distinct_disc_thmsss, |
|
1146 |
exhaust_discs = exhaust_disc_thms, exhaust_sels = exhaust_sel_thms, |
|
1147 |
collapses = all_collapse_thms, expands = expand_thms, split_sels = split_sel_thms, |
|
1148 |
split_sel_asms = split_sel_asm_thms, case_eq_ifs = case_eq_if_thms} |
|
57629
e88b5f59cade
use the noted theorem whenever possible, because it has a named derivation (leading to cleaner proof terms)
blanchet
parents:
57260
diff
changeset
|
1149 |
|> morph_ctr_sugar (substitute_noted_thm noted); |
49019 | 1150 |
in |
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
1151 |
(ctr_sugar, lthy' |> register_ctr_sugar plugins ctr_sugar) |
49019 | 1152 |
end; |
49017 | 1153 |
in |
61101
7b915ca69af1
use open/close_target rather than Local_Theory.restore to get polymorphic definitions;
traytel
parents:
60822
diff
changeset
|
1154 |
(goalss, after_qed, lthy) |
49017 | 1155 |
end; |
1156 |
||
58675 | 1157 |
fun free_constructors kind tacss = (fn (goalss, after_qed, lthy) => |
70494 | 1158 |
map2 (map2 (Thm.close_derivation \<^here> oo Goal.prove_sorry lthy [] [])) goalss tacss |
58675 | 1159 |
|> (fn thms => after_qed thms lthy)) oo prepare_free_constructors kind (K I) (K I); |
49280
52413dc96326
allow default values for selectors in low-level "wrap_data" command
blanchet
parents:
49278
diff
changeset
|
1160 |
|
58675 | 1161 |
fun free_constructors_cmd kind = (fn (goalss, after_qed, lthy) => |
49297 | 1162 |
Proof.theorem NONE (snd oo after_qed) (map (map (rpair [])) goalss) lthy) oo |
58675 | 1163 |
prepare_free_constructors kind Plugin_Name.make_filter Syntax.read_term; |
49297 | 1164 |
|
69593 | 1165 |
val parse_bound_term = Parse.binding --| \<^keyword>\<open>:\<close> -- Parse.term; |
49280
52413dc96326
allow default values for selectors in low-level "wrap_data" command
blanchet
parents:
49278
diff
changeset
|
1166 |
|
58660 | 1167 |
type ctr_options = Plugin_Name.filter * bool; |
1168 |
type ctr_options_cmd = (Proof.context -> Plugin_Name.filter) * bool; |
|
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
1169 |
|
58660 | 1170 |
val default_ctr_options : ctr_options = (Plugin_Name.default_filter, false); |
1171 |
val default_ctr_options_cmd : ctr_options_cmd = (K Plugin_Name.default_filter, false); |
|
58189
9d714be4f028
added 'plugins' option to control which hooks are enabled
blanchet
parents:
58188
diff
changeset
|
1172 |
|
55469
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
1173 |
val parse_ctr_options = |
69593 | 1174 |
Scan.optional (\<^keyword>\<open>(\<close> |-- Parse.list1 |
59281 | 1175 |
(Plugin_Name.parse_filter >> (apfst o K) |
1176 |
|| Parse.reserved "discs_sels" >> (apsnd o K o K true)) --| |
|
69593 | 1177 |
\<^keyword>\<open>)\<close> |
58659
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
1178 |
>> (fn fs => fold I fs default_ctr_options_cmd)) |
6c9821c32dd5
Local_Interpretation is superseded by Plugin with formal Plugin_Name management, avoiding undeclared strings;
wenzelm
parents:
58634
diff
changeset
|
1179 |
default_ctr_options_cmd; |
49278 | 1180 |
|
55469
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
1181 |
fun parse_ctr_spec parse_ctr parse_arg = |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
1182 |
parse_opt_binding_colon -- parse_ctr -- Scan.repeat parse_arg; |
55469
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
1183 |
|
57091 | 1184 |
val parse_ctr_specs = Parse.enum1 "|" (parse_ctr_spec Parse.term Parse.binding); |
69593 | 1185 |
val parse_sel_default_eqs = Scan.optional (\<^keyword>\<open>where\<close> |-- Parse.enum1 "|" Parse.prop) []; |
55469
b19dd108f0c2
aligned the syntax for 'free_constructors' on the 'datatype_new' and 'codatatype' syntax
blanchet
parents:
55468
diff
changeset
|
1186 |
|
49017 | 1187 |
val _ = |
69593 | 1188 |
Outer_Syntax.local_theory_to_proof \<^command_keyword>\<open>free_constructors\<close> |
55468
98b25c51e9e5
renamed 'wrap_free_constructors' to 'free_constructors' (cf. 'functor', 'bnf', etc.)
blanchet
parents:
55464
diff
changeset
|
1189 |
"register an existing freely generated type's constructors" |
69593 | 1190 |
(parse_ctr_options -- Parse.binding --| \<^keyword>\<open>for\<close> -- parse_ctr_specs |
57200
aab87ffa60cc
use 'where' clause for selector default value syntax
blanchet
parents:
57094
diff
changeset
|
1191 |
-- parse_sel_default_eqs |
58675 | 1192 |
>> free_constructors_cmd Unknown); |
49017 | 1193 |
|
71247 | 1194 |
|
1195 |
||
71248 | 1196 |
(** external views **) |
1197 |
||
1198 |
(* document antiquotations *) |
|
71247 | 1199 |
|
1200 |
local |
|
1201 |
||
1202 |
fun antiquote_setup binding co = |
|
1203 |
Thy_Output.antiquotation_pretty_source_embedded binding |
|
1204 |
((Scan.ahead (Scan.lift Parse.not_eof) >> Token.pos_of) -- |
|
1205 |
Args.type_name {proper = true, strict = true}) |
|
1206 |
(fn ctxt => fn (pos, type_name) => |
|
1207 |
let |
|
1208 |
fun err () = |
|
1209 |
error ("Bad " ^ Binding.name_of binding ^ ": " ^ quote type_name ^ Position.here pos); |
|
1210 |
in |
|
1211 |
(case ctr_sugar_of ctxt type_name of |
|
1212 |
NONE => err () |
|
1213 |
| SOME {kind, T = T0, ctrs = ctrs0, ...} => |
|
1214 |
let |
|
1215 |
val _ = if co = (kind = Codatatype) then () else err (); |
|
1216 |
||
1217 |
val T = Logic.unvarifyT_global T0; |
|
1218 |
val ctrs = map Logic.unvarify_global ctrs0; |
|
1219 |
||
1220 |
val pretty_typ_bracket = Syntax.pretty_typ (Config.put pretty_priority 1001 ctxt); |
|
1221 |
fun pretty_ctr ctr = |
|
1222 |
Pretty.block (Pretty.breaks (Syntax.pretty_term ctxt ctr :: |
|
1223 |
map pretty_typ_bracket (binder_types (fastype_of ctr)))); |
|
1224 |
in |
|
1225 |
Pretty.block (Pretty.keyword1 (Binding.name_of binding) :: Pretty.brk 1 :: |
|
1226 |
Syntax.pretty_typ ctxt T :: Pretty.str " =" :: Pretty.brk 1 :: |
|
1227 |
flat (separate [Pretty.brk 1, Pretty.str "| "] (map (single o pretty_ctr) ctrs))) |
|
1228 |
end) |
|
1229 |
end); |
|
1230 |
||
1231 |
in |
|
1232 |
||
1233 |
val _ = |
|
1234 |
Theory.setup |
|
1235 |
(antiquote_setup \<^binding>\<open>datatype\<close> false #> |
|
1236 |
antiquote_setup \<^binding>\<open>codatatype\<close> true); |
|
1237 |
||
49017 | 1238 |
end; |
71247 | 1239 |
|
71248 | 1240 |
|
1241 |
(* theory export *) |
|
1242 |
||
71249 | 1243 |
val _ = Export_Theory.setup_presentation (fn context => fn thy => |
71248 | 1244 |
let |
1245 |
val parents = map (Data.get o Context.Theory) (Theory.parents_of thy); |
|
1246 |
val datatypes = |
|
1247 |
(Data.get (Context.Theory thy), []) |-> Symtab.fold |
|
1248 |
(fn (name, (pos, {kind, T, ctrs, ...})) => |
|
71253 | 1249 |
if kind = Record orelse exists (fn tab => Symtab.defined tab name) parents then I |
71248 | 1250 |
else |
1251 |
let |
|
71249 | 1252 |
val pos_properties = Thy_Info.adjust_pos_properties context pos; |
71248 | 1253 |
val typ = Logic.unvarifyT_global T; |
1254 |
val constrs = map Logic.unvarify_global ctrs; |
|
1255 |
val typargs = rev (fold Term.add_tfrees (Logic.mk_type typ :: constrs) []); |
|
1256 |
val constructors = map (fn t => (t, Term.type_of t)) constrs; |
|
1257 |
in |
|
1258 |
cons (pos_properties, (name, (kind = Codatatype, (typargs, (typ, constructors))))) |
|
1259 |
end); |
|
1260 |
in |
|
1261 |
if null datatypes then () |
|
1262 |
else |
|
1263 |
Export_Theory.export_body thy "datatypes" |
|
1264 |
let open XML.Encode Term_XML.Encode in |
|
1265 |
list (pair properties (pair string (pair bool (pair (list (pair string sort)) |
|
1266 |
(pair typ (list (pair (term (Sign.consts_of thy)) typ))))))) datatypes |
|
1267 |
end |
|
1268 |
end); |
|
1269 |
||
71247 | 1270 |
end; |