theory Test

imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp"

begin

atom_decl name

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 =

  (P.and_list1 dt_parser) -- fun_parser

end

*}

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

ML {*

fun add_raw s = s ^ "_raw"

fun add_raws ss = map add_raw ss

fun raw_bind bn = Binding.suffix_name "_raw" bn

fun replace_str ss s = 

  case (AList.lookup (op=) ss s) of 

     SOME s' => s'

   | NONE => s

fun replace_typ ty_ss (Type (a, Ts)) = Type (replace_str ty_ss a, map (replace_typ ty_ss) Ts)

  | replace_typ ty_ss T = T  

fun raw_dts ty_ss dts =

let

  val ty_ss' = ty_ss ~~ (add_raws ty_ss)

  fun raw_dts_aux1 (bind, tys, mx) =

    (raw_bind bind, map (replace_typ ty_ss') 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 replace_aterm trm_ss (Const (a, T)) = Const (replace_str trm_ss a, T)

  | replace_aterm trm_ss (Free (a, T)) = Free (replace_str trm_ss a, T)

  | replace_aterm trm_ss trm = trm

fun replace_term trm_ss ty_ss trm =

  trm |> Term.map_aterms (replace_aterm trm_ss) |> map_types (replace_typ ty_ss) 

*}

ML {*

fun get_constrs dts =

  flat (map (fn (_, _, _, constrs) => constrs) dts)

fun get_typed_constrs dts =

  flat (map (fn (_, bn, _, constrs) => 

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

fun get_constr_strs dts =

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

fun get_bn_fun_strs bn_funs =

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

*}

ML {*

fun raw_dts_decl dt_names dts lthy =

let

  val thy = ProofContext.theory_of lthy

  val conf = Datatype.default_config

  val dt_names' = add_raws dt_names

  val dt_full_names = map (Sign.full_bname thy) dt_names 

  val dts' = raw_dts dt_full_names dts

in

  lthy

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

end 

*}

ML {*

fun raw_bn_fun_decl dt_names dts bn_funs bn_eqs lthy =

let

  val thy = ProofContext.theory_of lthy

  val dt_names' = add_raws dt_names

  val dt_full_names = map (Sign.full_bname thy) dt_names 

  val dt_full_names' = map (Sign.full_bname thy) dt_names' 

  val ctrs_names = map (Sign.full_bname thy) (get_constr_strs dts)

  val ctrs_names' = map (fn (x, y) => (Sign.full_bname_path thy (add_raw x) (add_raw y))) 

    (get_typed_constrs dts)

  val bn_fun_strs = get_bn_fun_strs bn_funs

  val bn_fun_strs' = add_raws bn_fun_strs

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

    (raw_bind bn, Option.map (replace_typ (dt_full_names ~~ dt_full_names')) opt_ty, mx)) bn_funs

  val bn_eqs' = map (fn trm => 

    (Attrib.empty_binding, 

      (replace_term ((ctrs_names ~~ ctrs_names') @ (bn_fun_strs ~~ bn_fun_strs')) (dt_full_names ~~ dt_full_names') trm))) bn_eqs

in

  if null bn_eqs 

  then (([], []), lthy)

  else Primrec.add_primrec bn_funs' bn_eqs' lthy 

end 

*}

ML {* 

fun nominal_datatype2 dts bn_funs bn_eqs lthy =

let

  val dts_names = map (fn (_, s, _, _) => Binding.name_of s) dts

in

  lthy

  |> raw_dts_decl dts_names dts

  ||>> raw_bn_fun_decl dts_names dts bn_funs bn_eqs

end

*}

ML {*

(* makes a full named type out of a binding with tvars applied to it *)

fun mk_type thy bind tvrs =

  Type (Sign.full_name thy bind, map (fn s => TVar ((s, 0), [])) tvrs)

fun get_constrs2 thy dts =

let

  val dts' = map (fn (tvrs, tname, _, constrs) => (mk_type thy tname tvrs, constrs)) dts

in

  flat (map (fn (ty, constrs) => map (fn (bn, tys, mx) =>  (bn, tys ---> ty, mx)) constrs) dts')

end

*}

ML {*

fun nominal_datatype2_cmd (dt_strs, (bn_fun_strs, bn_eq_strs)) lthy =

let

  val thy = ProofContext.theory_of lthy

  fun prep_typ ((tvs, tname, mx), _) = (tname, length tvs, mx);

  (* adding the types for parsing datatypes *)

  val lthy_tmp = lthy

    |> Local_Theory.theory (Sign.add_types (map prep_typ dt_strs))

  fun prep_cnstr lthy (((cname, atys), mx), binders) =

    (cname, map (Syntax.read_typ lthy o snd) atys, mx)

  fun prep_dt lthy ((tvs, tname, mx), cnstrs) = 

    (tvs, tname, mx, map (prep_cnstr lthy) cnstrs)

  (* parsing the datatypes *)

  val dts_prep = map (prep_dt lthy_tmp) dt_strs

  (* adding constructors for parsing functions *)

  val lthy_tmp2 = lthy_tmp

    |> Local_Theory.theory (Sign.add_consts_i (get_constrs2 thy dts_prep))

  val (bn_fun_aux, bn_eq_aux) = fst (Specification.read_spec bn_fun_strs bn_eq_strs lthy_tmp2)

  fun prep_bn_fun ((bn, T), mx) = (bn, SOME T, mx) 

  fun prep_bn_eq (attr, t) = t

  val bn_fun_prep = map prep_bn_fun bn_fun_aux

  val bn_eq_prep = map prep_bn_eq bn_eq_aux 

in

  nominal_datatype2 dts_prep bn_fun_prep bn_eq_prep lthy |> snd

end

*}

(* Command Keyword *)

ML {*

let

   val kind = OuterKeyword.thy_decl

in

   OuterSyntax.local_theory "nominal_datatype" "test" kind 

     (main_parser >> nominal_datatype2_cmd)

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}"

typ lam_raw

term VAR_raw

term Test.BP_raw

thm bi_raw.simps

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" "name"

binder

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

where 

  "f PN = {}"

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

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

thm f_raw.simps

nominal_datatype trm0 =

  Var0 "name"

| App0 "trm0" "trm0"

| Lam0 x::"name" t::"trm0"          bind x in t 

| Let0 p::"pat0" "trm0" t::"trm0"   bind "f0 p" in t

and pat0 =

  PN0

| PS0 "name"

| PD0 "pat0" "pat0"

binder

  f0::"pat0 \<Rightarrow> name set"

where 

  "f0 PN0 = {}"

| "f0 (PS0 x) = {x}"

| "f0 (PD0 p1 p2) = (f0 p1) \<union> (f0 p2)"

thm f0_raw.simps

text {* example type schemes *}

datatype ty = 

  Var "name" 

| Fun "ty" "ty"

nominal_datatype tyS = 

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

(* example 1 from Terms.thy *)

nominal_datatype trm1 =

  Vr1 "name"

| Ap1 "trm1" "trm1"

| Lm1 x::"name" t::"trm1"      bind x in t 

| Lt1 p::"bp1" "trm1" t::"trm1" bind "bv1 p" in t 

and bp1 =

  BUnit1

| BV1 "name"

| BP1 "bp1" "bp1"

binder

  bv1

where

  "bv1 (BUnit1) = {}"

| "bv1 (BV1 x) = {atom x}"

| "bv1 (BP1 bp1 bp2) = (bv1 bp1) \<union> (bv1 bp2)"

thm bv1_raw.simps

(* example 2 from Terms.thy *)

nominal_datatype trm2 =

  Vr2 "name"

| Ap2 "trm2" "trm2"

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

| Lt2 r::"rassign" t::"trm2"    bind "bv2 r" in t

and rassign = 

  As "name" "trm2"

binder

  bv2

where

  "bv2 (As x t) = {atom x}"

(* example 3 from Terms.thy *)

nominal_datatype trm3 =

  Vr3 "name"

| Ap3 "trm3" "trm3"

| Lm3 x::"name" t::"trm3"        bind x in t

| Lt3 r::"rassigns3" t::"trm3"   bind "bv3 r" in t

and rassigns3 =

  ANil

| ACons "name" "trm3" "rassigns3"

binder

  bv3

where

  "bv3 ANil = {}"

| "bv3 (ACons x t as) = {atom x} \<union> (bv3 as)"

(* example 4 from Terms.thy *)

nominal_datatype trm4 =

  Vr4 "name"

| Ap4 "trm4" "trm4 list"

| Lm4 x::"name" t::"trm4"  bind x in t

(* example 5 from Terms.thy *)

nominal_datatype trm5 =

  Vr5 "name"

| Ap5 "trm5" "trm5"

| Lt5 l::"lts" t::"trm5"  bind "bv5 l" in t

and lts =

  Lnil

| Lcons "name" "trm5" "lts"

binder

  bv5

where

  "bv5 Lnil = {}"

| "bv5 (Lcons n t ltl) = {atom n} \<union> (bv5 ltl)"

(* example 6 from Terms.thy *)

nominal_datatype trm6 =

  Vr6 "name"

| Lm6 x::"name" t::"trm6"         bind x in t

| Lt6 left::"trm6" right::"trm6"  bind "bv6 left" in right

binder

  bv6

where

  "bv6 (Vr6 n) = {}"

| "bv6 (Lm6 n t) = {atom n} \<union> bv6 t"

| "bv6 (Lt6 l r) = bv6 l \<union> bv6 r"

(* example 7 from Terms.thy *)

nominal_datatype trm7 =

  Vr7 "name"

| Lm7 l::"name" r::"trm7"   bind l in r

| Lt7 l::"trm7" r::"trm7"   bind "bv7 l" in r

binder 

  bv7 

where

  "bv7 (Vr7 n) = {atom n}"

| "bv7 (Lm7 n t) = bv7 t - {atom n}"

| "bv7 (Lt7 l r) = bv7 l \<union> bv7 r"

(* example 8 from Terms.thy *)

nominal_datatype foo8 =

  Foo0 "name"

| Foo1 b::"bar8" f::"foo8" bind "bv8 b" in foo

and bar8 =

  Bar0 "name"

| Bar1 "name" s::"name" b::"bar8" bind s in b

binder 

  bv8

where

  "bv8 (Bar0 x) = {}"

| "bv8 (Bar1 v x b) = {atom v}"

(* example 9 from Terms.thy *)

nominal_datatype lam9 =

  Var9 "name"

| Lam9 n::"name" l::"lam9" bind n in l

and bla9 =

  Bla9 f::"lam9" s::"lam9" bind "bv9 f" in s

binder

  bv9

where

  "bv9 (Var9 x) = {}"

| "bv9 (Lam9 x b) = {atom x}"

end