theory Test

imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp"

begin

atom_decl name

(* 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 *}

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:  term list 

          ^^^^^^^^^

          the equations of the binding functions

          (Trueprop equations)

*}

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

ML {* 

(* nominal datatype parser *)

local

  structure P = OuterParse

in

val _ = OuterKeyword.keyword "bind"

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

(* binding specification *)

(* should use and_list *)

val bind_parser = 

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

val constr_parser =

  P.binding -- Scan.repeat anno_typ

(* datatype parser *)

val dt_parser =

  ((P.type_args -- P.binding -- P.opt_infix) >> P.triple1) -- 

    (P.$$$ "=" |-- P.enum1 "|" ((constr_parser -- bind_parser -- P.opt_mixfix) >> P.triple_swap))

(* function equation parser *)

val fun_parser = 

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

(* main parser *)

val main_parser =

end

*}

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

ML {*

fun add_raw s = s ^ "_raw"

fun raw_bind bn = Binding.suffix_name "_raw" bn

fun raw_str [] s = s

  | raw_str (s'::ss) s = 

      if (Long_Name.base_name s) = s' 

      then add_raw s

      else raw_str ss s

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_aterm trm_strs (Const (a, T)) = Const (raw_str trm_strs a, T)

  | raw_aterm trm_strs (Free (a, T)) = Free (raw_str trm_strs a, T)

  | raw_aterm trm_strs trm = trm

fun raw_term trm_strs ty_strs trm =

  trm |> Term.map_aterms (raw_aterm trm_strs) |> map_types (raw_typ ty_strs) 

fun raw_dts ty_strs dts =

let

  fun raw_dts_aux1 (bind, tys, mx) =

    (raw_bind bind, map (raw_typ ty_strs) tys, mx)

  fun raw_dts_aux2 (ty_args, bind, mx, constrs) =

    (ty_args, raw_bind bind, mx, map raw_dts_aux1 constrs)

in

  map raw_dts_aux2 dts

end

fun get_constr_strs dts =

  flat (map (fn (_, _, _, constrs) => map (fn (bn, _, _) => Binding.name_of bn) constrs) dts)

fun get_bn_fun_strs bn_funs =

  map (fn (bn_fun, _, _) => Binding.name_of bn_fun) bn_funs

*}

ML {*

let

  val conf = Datatype.default_config

  val dt_names' = map add_raw dt_names

  val dts' = raw_dts dt_names dts

  val bn_fun_strs = get_bn_fun_strs bn_funs

  val bn_funs' = map (fn (bn, opt_ty, mx) => 

    (raw_bind bn, Option.map (raw_typ dt_names) opt_ty, mx)) bn_funs

  val bn_eqs' = map (fn trm => 

in

end 

*}

let

in

end

*}

ML {*

let

in

end

*}

(* Command Keyword *)

ML {*

let

   val kind = OuterKeyword.thy_decl

in

end

*}

text {* example 1 *}

nominal_datatype lam =

  VAR "name"

| APP "lam" "lam"

| LET bp::"bp" t::"lam"   bind "bi bp" in t ("Let _ in _" [100,100] 100)

and bp = 

  BP "name" "lam"  ("_ ::= _" [100,100] 100)

binder

  bi::"bp \<Rightarrow> name set"

where

  "bi (BP x t) = {x}"

print_theorems

text {* examples 2 *}

nominal_datatype trm =

  Var "name"

| App "trm" "trm"

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

| Let p::"pat" "trm" t::"trm"   bind "f p" in t

and pat =

  PN

| PS "name"

| PD "name \<times> name"

binder

  f::"pat \<Rightarrow> name set"

where 

  "f PN = {}"

| "f (PS x) = {x}"

| "f (PD (x,y)) = {x,y}"

nominal_datatype trm2 =

  Var2 "name"

| App2 "trm2" "trm2"

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

| Let2 p::"pat2" "trm2" t::"trm2"   bind "f2 p" in t

and pat2 =

  PN2

| PS2 "name"

| PD2 "pat2 \<times> pat2"

binder

  f2::"pat2 \<Rightarrow> name set"

where 

  "f2 PN2 = {}"

| "f2 (PS2 x) = {x}"

| "f2 (PD2 (p1, p2)) = (f2 p1) \<union> (f2 p2)"

text {* example type schemes *}

datatype ty = 

  Var "name" 

| Fun "ty" "ty"

nominal_datatype tyS = 

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

end