(* tests *)

ML {*

Datatype.datatype_cmd;

Datatype.add_datatype Datatype.default_config;

Primrec.add_primrec_cmd;

Primrec.add_primrec;

Primrec.add_primrec_simple;

*}

section {* test for setting up a primrec on the ML-level *}

datatype simple = Foo

local_setup {* 

Primrec.add_primrec [(@{binding "Bar"}, SOME @{typ "simple \<Rightarrow> nat"}, NoSyn)]

 [(Attrib.empty_binding, HOLogic.mk_Trueprop @{term "Bar Foo = Suc 0"})] #> snd

*}

thm Bar.simps

lemma "Bar Foo = XXX"

apply(simp)

oops

section {* test for setting up a datatype on the ML-level *}

Datatype.add_datatype Datatype.default_config

    [(@{binding "zero"}, [], NoSyn),(@{binding "suc"}, [Type ("Test.foo", [])], NoSyn)])

  ] #> snd

*}

ML {*

  PolyML.makestring (#descr (Datatype.the_info @{theory} "Test.foo"))

(* adds "_raw" to the end of constants and types *)

ML {*

fun raw_str [] s = s

  | raw_str (s'::ss) s = (if s = s' then s ^ "_str" else raw_str ss s)

val raw_strs = map raw_str

fun raw_typ ty_strs (Type (a, Ts)) = Type (raw_str ty_strs a, map (raw_typ ty_strs) Ts)

  | raw_typ ty_strs T = T  

fun raw_term trm_strs ty_strs (Const (a, T)) = Const (raw_str trm_strs a, raw_typ ty_strs T)

  | raw_term trm_strs ty_strs (Abs (a, T, t)) = Abs (a, T, raw_term trm_strs ty_strs t)

  | raw_term trm_strs ty_strs (t $ u) = (raw_term trm_strs ty_strs t) $ (raw_term trm_strs ty_strs u)

fun raw_binding bn = Binding.suffix_name "_raw" bn

section{* Interface for nominal_datatype *}

text {*

Nominal-Datatype-part:

1st Arg: string list  

         ^^^^^^^^^^^

         strings of the types to be defined

2nd Arg: (string list * binding * mixfix * (binding * typ list * mixfix) list) list

         ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

               type(s) to be defined             constructors list

               (ty args, name, syn)              (name, typs, syn)

Binder-Function-part:

3rd Arg: (binding * typ option * mixfix) list 

         ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^    

            binding function(s)           

              to be defined               

            (name, type, syn)             

4th Arg: (attrib * term) list 

          ^^^^^^^^^^^^^^^^^^^

          the equations of the binding functions

          (Trueprop equations)

ML {* Datatype.add_datatype *}

fun raw_definitions dt_names dts bn_funs bn_eqs lthy =

let

  val conf = Datatype.default_config

  val bn_funs' = map (fn (bn, ty) => (raw_binding bn, ty, NoSyn)) bn_funs

  val bn_eqs' = map (pair Attrib.empty_binding) bn_eqs

in 

  lthy

  |> (Local_Theory.theory_result (Datatype.add_datatype conf dt_names dts))

  ||>> Primrec.add_primrec bn_funs' bn_eqs'

end 

ML {* @{binding "zero"} *}

local_setup {*

raw_definitions

  ["foo'"]

  [([], @{binding "foo'"}, NoSyn, 

    [(@{binding "zero'"}, [], NoSyn),(@{binding "suc'"}, [Type ("Test.foo'", [])], NoSyn)])]

  [(@{binding "Bar'"}, SOME @{typ "simple \<Rightarrow> nat"})]

  [HOLogic.mk_Trueprop @{term "Bar'_raw Foo = Suc 0"}]

  #> snd

*}

typ foo'

thm Bar'.simps

text {*****************************************************}

ML {* 

(* nominal datatype parser *)

local

  structure P = OuterParse

in

val _ = OuterKeyword.keyword "bind"

val anno_typ = Scan.option (P.name --| P.$$$ "::") -- P.typ

  P.enum "," ((P.$$$ "bind" |-- P.term) -- (P.$$$ "in" |-- P.name))

  P.type_args -- P.binding -- P.opt_infix -- 

    (P.$$$ "=" |-- P.enum1 "|" (P.binding -- (Scan.repeat anno_typ) -- bind_parser -- P.opt_mixfix))

  Scan.optional (P.$$$ "binder" |-- P.fixes -- SpecParse.where_alt_specs) ([],[])

(* main parser *)

val parser =

  P.and_list1 dt_parser -- fun_parser

end

fun print_bind (s1, s2) = "bind " ^ s1 ^ " in " ^ s2

fun print_single_dt lthy (((s2, s3), syn), constrs) =

fun print_single_fun_eq lthy (at, s) = 

fun print_single_fun_fix lthy (b, _, _) = 

  val _ = warning (implode (separate "\n" (map (print_single_dt lthy) dts)));

  val _ = warning (implode (separate "\n" (map (print_single_fun_fix lthy) funs)));

  val _ = warning (implode (separate "\n" (map (print_single_fun_eq lthy) feqs)));

fun parse_fun lthy (b, NONE, m) = (b, NONE, m)

  | parse_fun lthy (b, SOME ty, m) = (b, SOME (Syntax.read_typ lthy ty), m)

fun parse_feq lthy (b, t) = (b, Syntax.read_prop lthy t);

fun parse_anno_ty lthy (anno, ty) = (anno, Syntax.read_typ lthy ty);

fun parse_constr lthy (((constr_name, ty_args), bind), mx) =

  (((constr_name, map (parse_anno_ty lthy) ty_args), bind), mx);

fun parse_dt lthy (((ty_args, ty_name), mx), constrs) =

   (((ty_args, ty_name), mx), map (parse_constr lthy) constrs);

*}

ML {*

fun nominal_datatype2_cmd (dt_strs, (fun_strs, feq_strs)) thy =

  val thy' = dt_defn (map transp_dt dt_strs) thy

  val lthy' = fn_defn_cmd fun_strs feq_strs lthy

  val funs = map (parse_fun lthy') fun_strs

  val feqs = map (parse_feq lthy') feq_strs

  val dts = map (parse_dt lthy') dt_strs

  val _ = print_dts (dts, (funs, feqs)) lthy'

  Local_Theory.exit_global lthy'

| Lam x::"name" t::"trm"        bind x in t 

| Lam2 x::"name" t::"trm2"          bind x in t 

  All xs::"name list" ty::"ty" bind xs in ty