7 |
7 |
8 signature BNF_WRAP = |
8 signature BNF_WRAP = |
9 sig |
9 sig |
10 val no_binder: binding |
10 val no_binder: binding |
11 val mk_half_pairss: 'a list -> ('a * 'a) list list |
11 val mk_half_pairss: 'a list -> ('a * 'a) list list |
12 val wrap_data: ({prems: thm list, context: Proof.context} -> tactic) list list -> |
12 val wrap_datatype: ({prems: thm list, context: Proof.context} -> tactic) list list -> |
13 (term list * term) * (binding list * binding list list) -> local_theory -> local_theory |
13 (term list * term) * (binding list * binding list list) -> local_theory -> local_theory |
14 end; |
14 end; |
15 |
15 |
16 structure BNF_Wrap : BNF_WRAP = |
16 structure BNF_Wrap : BNF_WRAP = |
17 struct |
17 struct |
60 case head_of t of |
60 case head_of t of |
61 Const (s, _) => s |
61 Const (s, _) => s |
62 | Free (s, _) => s |
62 | Free (s, _) => s |
63 | _ => error "Cannot extract name of constructor"; |
63 | _ => error "Cannot extract name of constructor"; |
64 |
64 |
65 fun prepare_wrap_data prep_term ((raw_ctrs, raw_case), (raw_disc_binders, raw_sel_binderss)) |
65 fun prepare_wrap_datatype prep_term ((raw_ctrs, raw_case), (raw_disc_binders, raw_sel_binderss)) |
66 no_defs_lthy = |
66 no_defs_lthy = |
67 let |
67 let |
68 (* TODO: sanity checks on arguments *) |
68 (* TODO: sanity checks on arguments *) |
69 (* TODO: attributes (simp, case_names, etc.) *) |
69 (* TODO: attributes (simp, case_names, etc.) *) |
70 (* TODO: case syntax *) |
70 (* TODO: case syntax *) |
505 end; |
505 end; |
506 in |
506 in |
507 (goalss, after_qed, lthy') |
507 (goalss, after_qed, lthy') |
508 end; |
508 end; |
509 |
509 |
510 fun wrap_data tacss = (fn (goalss, after_qed, lthy) => |
510 fun wrap_datatype tacss = (fn (goalss, after_qed, lthy) => |
511 map2 (map2 (Skip_Proof.prove lthy [] [])) goalss tacss |
511 map2 (map2 (Skip_Proof.prove lthy [] [])) goalss tacss |
512 |> (fn thms => after_qed thms lthy)) oo |
512 |> (fn thms => after_qed thms lthy)) oo |
513 prepare_wrap_data (K I) (* FIXME? (singleton o Type_Infer_Context.infer_types) *) |
513 prepare_wrap_datatype (K I) (* FIXME? (singleton o Type_Infer_Context.infer_types) *) |
514 |
514 |
515 val parse_bindings = Parse.$$$ "[" |-- Parse.list Parse.binding --| Parse.$$$ "]"; |
515 val parse_bindings = Parse.$$$ "[" |-- Parse.list Parse.binding --| Parse.$$$ "]"; |
516 val parse_bindingss = Parse.$$$ "[" |-- Parse.list parse_bindings --| Parse.$$$ "]"; |
516 val parse_bindingss = Parse.$$$ "[" |-- Parse.list parse_bindings --| Parse.$$$ "]"; |
517 |
517 |
518 val wrap_data_cmd = (fn (goalss, after_qed, lthy) => |
518 val wrap_datatype_cmd = (fn (goalss, after_qed, lthy) => |
519 Proof.theorem NONE after_qed (map (map (rpair [])) goalss) lthy) oo |
519 Proof.theorem NONE after_qed (map (map (rpair [])) goalss) lthy) oo |
520 prepare_wrap_data Syntax.read_term; |
520 prepare_wrap_datatype Syntax.read_term; |
521 |
521 |
522 val _ = |
522 val _ = |
523 Outer_Syntax.local_theory_to_proof @{command_spec "wrap_data"} "wraps an existing datatype" |
523 Outer_Syntax.local_theory_to_proof @{command_spec "wrap_data"} "wraps an existing datatype" |
524 (((Parse.$$$ "[" |-- Parse.list Parse.term --| Parse.$$$ "]") -- Parse.term -- |
524 (((Parse.$$$ "[" |-- Parse.list Parse.term --| Parse.$$$ "]") -- Parse.term -- |
525 Scan.optional (parse_bindings -- Scan.optional parse_bindingss []) ([], [])) |
525 Scan.optional (parse_bindings -- Scan.optional parse_bindingss []) ([], [])) |
526 >> wrap_data_cmd); |
526 >> wrap_datatype_cmd); |
527 |
527 |
528 end; |
528 end; |