src/HOL/Codatatype/Tools/bnf_wrap.ML
changeset 49199 7c9a3c67c55d
parent 49174 41790d616f63
child 49201 c69c2c18dccb
equal deleted inserted replaced
49198:38af9102ee75 49199:7c9a3c67c55d
     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;