23 val get_constrs : theory -> string -> (string * typ) list option |
23 val get_constrs : theory -> string -> (string * typ) list option |
24 val get_all : theory -> info Symtab.table |
24 val get_all : theory -> info Symtab.table |
25 val info_of_constr : theory -> string * typ -> info option |
25 val info_of_constr : theory -> string * typ -> info option |
26 val info_of_case : theory -> string -> info option |
26 val info_of_case : theory -> string -> info option |
27 val interpretation : (config -> string list -> theory -> theory) -> theory -> theory |
27 val interpretation : (config -> string list -> theory -> theory) -> theory -> theory |
28 val make_case : Proof.context -> DatatypeCase.config -> string list -> term -> |
28 val make_case : Proof.context -> Datatype_Case.config -> string list -> term -> |
29 (term * term) list -> term * (term * (int * bool)) list |
29 (term * term) list -> term * (term * (int * bool)) list |
30 val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option |
30 val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option |
31 val read_typ: theory -> string -> (string * sort) list -> typ * (string * sort) list |
31 val read_typ: theory -> string -> (string * sort) list -> typ * (string * sort) list |
32 val cert_typ: theory -> typ -> (string * sort) list -> typ * (string * sort) list |
32 val cert_typ: theory -> typ -> (string * sort) list -> typ * (string * sort) list |
33 val mk_case_names_induct: descr -> attribute |
33 val mk_case_names_induct: descr -> attribute |
102 fun the_spec thy dtco = |
102 fun the_spec thy dtco = |
103 let |
103 let |
104 val info as { descr, index, sorts = raw_sorts, ... } = the_info thy dtco; |
104 val info as { descr, index, sorts = raw_sorts, ... } = the_info thy dtco; |
105 val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index; |
105 val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index; |
106 val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v)) |
106 val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v)) |
107 o DatatypeAux.dest_DtTFree) dtys; |
107 o Datatype_Aux.dest_DtTFree) dtys; |
108 val cos = map |
108 val cos = map |
109 (fn (co, tys) => (co, map (DatatypeAux.typ_of_dtyp descr sorts) tys)) raw_cos; |
109 (fn (co, tys) => (co, map (Datatype_Aux.typ_of_dtyp descr sorts) tys)) raw_cos; |
110 in (sorts, cos) end; |
110 in (sorts, cos) end; |
111 |
111 |
112 fun the_descr thy (raw_tycos as raw_tyco :: _) = |
112 fun the_descr thy (raw_tycos as raw_tyco :: _) = |
113 let |
113 let |
114 val info = the_info thy raw_tyco; |
114 val info = the_info thy raw_tyco; |
195 fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i))); |
195 fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i))); |
196 val bnames = map the_bname (distinct (op =) (maps dt_recs args)); |
196 val bnames = map the_bname (distinct (op =) (maps dt_recs args)); |
197 in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end; |
197 in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end; |
198 |
198 |
199 fun induct_cases descr = |
199 fun induct_cases descr = |
200 DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr)); |
200 Datatype_Prop.indexify_names (maps (dt_cases descr) (map #2 descr)); |
201 |
201 |
202 fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i)); |
202 fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i)); |
203 |
203 |
204 in |
204 in |
205 |
205 |
212 end; |
212 end; |
213 |
213 |
214 |
214 |
215 (* translation rules for case *) |
215 (* translation rules for case *) |
216 |
216 |
217 fun make_case ctxt = DatatypeCase.make_case |
217 fun make_case ctxt = Datatype_Case.make_case |
218 (info_of_constr (ProofContext.theory_of ctxt)) ctxt; |
218 (info_of_constr (ProofContext.theory_of ctxt)) ctxt; |
219 |
219 |
220 fun strip_case ctxt = DatatypeCase.strip_case |
220 fun strip_case ctxt = Datatype_Case.strip_case |
221 (info_of_case (ProofContext.theory_of ctxt)); |
221 (info_of_case (ProofContext.theory_of ctxt)); |
222 |
222 |
223 fun add_case_tr' case_names thy = |
223 fun add_case_tr' case_names thy = |
224 Sign.add_advanced_trfuns ([], [], |
224 Sign.add_advanced_trfuns ([], [], |
225 map (fn case_name => |
225 map (fn case_name => |
226 let val case_name' = Sign.const_syntax_name thy case_name |
226 let val case_name' = Sign.const_syntax_name thy case_name |
227 in (case_name', DatatypeCase.case_tr' info_of_case case_name') |
227 in (case_name', Datatype_Case.case_tr' info_of_case case_name') |
228 end) case_names, []) thy; |
228 end) case_names, []) thy; |
229 |
229 |
230 val trfun_setup = |
230 val trfun_setup = |
231 Sign.add_advanced_trfuns ([], |
231 Sign.add_advanced_trfuns ([], |
232 [("_case_syntax", DatatypeCase.case_tr true info_of_constr)], |
232 [("_case_syntax", Datatype_Case.case_tr true info_of_constr)], |
233 [], []); |
233 [], []); |
234 |
234 |
235 |
235 |
236 |
236 |
237 (** document antiquotation **) |
237 (** document antiquotation **) |
297 val thy2 = thy1 |> Theory.checkpoint; |
297 val thy2 = thy1 |> Theory.checkpoint; |
298 val flat_descr = flat descr; |
298 val flat_descr = flat descr; |
299 val new_type_names = map Long_Name.base_name (the_default dt_names alt_names); |
299 val new_type_names = map Long_Name.base_name (the_default dt_names alt_names); |
300 val _ = message config ("Deriving properties for datatype(s) " ^ commas_quote new_type_names); |
300 val _ = message config ("Deriving properties for datatype(s) " ^ commas_quote new_type_names); |
301 |
301 |
302 val (exhaust, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names |
302 val (exhaust, thy3) = Datatype_Abs_Proofs.prove_casedist_thms config new_type_names |
303 descr sorts induct (mk_case_names_exhausts flat_descr dt_names) thy2; |
303 descr sorts induct (mk_case_names_exhausts flat_descr dt_names) thy2; |
304 val (nchotomys, thy4) = DatatypeAbsProofs.prove_nchotomys config new_type_names |
304 val (nchotomys, thy4) = Datatype_Abs_Proofs.prove_nchotomys config new_type_names |
305 descr sorts exhaust thy3; |
305 descr sorts exhaust thy3; |
306 val ((rec_names, rec_rewrites), thy5) = DatatypeAbsProofs.prove_primrec_thms |
306 val ((rec_names, rec_rewrites), thy5) = Datatype_Abs_Proofs.prove_primrec_thms |
307 config new_type_names descr sorts (#inject o the o Symtab.lookup (get_all thy4)) |
307 config new_type_names descr sorts (#inject o the o Symtab.lookup (get_all thy4)) |
308 inject (distinct, all_distincts thy2 (get_rec_types flat_descr sorts)) |
308 inject (distinct, all_distincts thy2 (get_rec_types flat_descr sorts)) |
309 induct thy4; |
309 induct thy4; |
310 val ((case_rewrites, case_names), thy6) = DatatypeAbsProofs.prove_case_thms |
310 val ((case_rewrites, case_names), thy6) = Datatype_Abs_Proofs.prove_case_thms |
311 config new_type_names descr sorts rec_names rec_rewrites thy5; |
311 config new_type_names descr sorts rec_names rec_rewrites thy5; |
312 val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names |
312 val (case_congs, thy7) = Datatype_Abs_Proofs.prove_case_congs new_type_names |
313 descr sorts nchotomys case_rewrites thy6; |
313 descr sorts nchotomys case_rewrites thy6; |
314 val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names |
314 val (weak_case_congs, thy8) = Datatype_Abs_Proofs.prove_weak_case_congs new_type_names |
315 descr sorts thy7; |
315 descr sorts thy7; |
316 val (splits, thy9) = DatatypeAbsProofs.prove_split_thms |
316 val (splits, thy9) = Datatype_Abs_Proofs.prove_split_thms |
317 config new_type_names descr sorts inject distinct exhaust case_rewrites thy8; |
317 config new_type_names descr sorts inject distinct exhaust case_rewrites thy8; |
318 |
318 |
319 val inducts = Project_Rule.projections (ProofContext.init thy2) induct; |
319 val inducts = Project_Rule.projections (ProofContext.init thy2) induct; |
320 val dt_infos = map_index |
320 val dt_infos = map_index |
321 (make_dt_info alt_names flat_descr sorts induct inducts rec_names rec_rewrites) |
321 (make_dt_info alt_names flat_descr sorts induct inducts rec_names rec_rewrites) |
414 |
414 |
415 fun mk_spec (i, (tyco, constr)) = (i, (tyco, |
415 fun mk_spec (i, (tyco, constr)) = (i, (tyco, |
416 map (DtTFree o fst) vs, |
416 map (DtTFree o fst) vs, |
417 (map o apsnd) dtyps_of_typ constr)) |
417 (map o apsnd) dtyps_of_typ constr)) |
418 val descr = map_index mk_spec cs; |
418 val descr = map_index mk_spec cs; |
419 val injs = DatatypeProp.make_injs [descr] vs; |
419 val injs = Datatype_Prop.make_injs [descr] vs; |
420 val half_distincts = map snd (DatatypeProp.make_distincts [descr] vs); |
420 val half_distincts = map snd (Datatype_Prop.make_distincts [descr] vs); |
421 val ind = DatatypeProp.make_ind [descr] vs; |
421 val ind = Datatype_Prop.make_ind [descr] vs; |
422 val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts]; |
422 val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts]; |
423 |
423 |
424 fun after_qed' raw_thms = |
424 fun after_qed' raw_thms = |
425 let |
425 let |
426 val [[[raw_induct]], raw_inject, half_distinct] = |
426 val [[[raw_induct]], raw_inject, half_distinct] = |