1 theory Test

     2 imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp"

     3 begin

     4 

     5 atom_decl name

     6 

     7 

     8 (* tests *)

     9 ML {*

    10 Datatype.datatype_cmd;

    11 Datatype.add_datatype Datatype.default_config;

    12 

    13 Primrec.add_primrec_cmd;

    14 Primrec.add_primrec;

    15 Primrec.add_primrec_simple;

    16 *}

    17 

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

    19 

    20 section{* Interface for nominal_datatype *}

    21 

    22 text {*

    23 

    24 Nominal-Datatype-part:

    25 

    26 1st Arg: string list  

    27          ^^^^^^^^^^^

    28          strings of the types to be defined

    29 

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

    31          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

    32                type(s) to be defined             constructors list

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

    34 

    35 Binder-Function-part:

    36 

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

    38          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^    

    39             binding function(s)           

    40               to be defined               

    41             (name, type, syn)             

    42 

    43 4th Arg:  term list 

    44           ^^^^^^^^^

    45           the equations of the binding functions

    46           (Trueprop equations)

    47 *}

    48 

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

    50 ML {* 

    51 (* nominal datatype parser *)

    52 local

    53   structure P = OuterParse

    54 in

    55 

    56 val _ = OuterKeyword.keyword "bind"

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

    58 

    59 (* binding specification *)

    60 (* should use and_list *)

    61 val bind_parser = 

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

    63 

    64 val constr_parser =

    65   P.binding -- Scan.repeat anno_typ

    66 

    67 (* datatype parser *)

    68 val dt_parser =

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

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

    71 

    72 (* function equation parser *)

    73 val fun_parser = 

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

    75 

    76 (* main parser *)

    77 val main_parser =

    78   (P.and_list1 dt_parser) -- fun_parser

    79 

    80 end

    81 *}

    82 

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

    84 ML {*

    85 fun add_raw s = s ^ "_raw"

    86 fun add_raws ss = map add_raw ss

    87 fun raw_bind bn = Binding.suffix_name "_raw" bn

    88 

    89 fun replace_str ss s = 

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

    91      SOME s' => s'

    92    | NONE => s

    93 

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

    95   | replace_typ ty_ss T = T  

    96 

    97 fun raw_dts ty_ss dts =

    98 let

    99   val ty_ss' = ty_ss ~~ (add_raws ty_ss)

   100 

   101   fun raw_dts_aux1 (bind, tys, mx) =

   102     (raw_bind bind, map (replace_typ ty_ss') tys, mx)

   103 

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

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

   106 in

   107   map raw_dts_aux2 dts

   108 end

   109 

   110 fun replace_aterm trm_ss (Const (a, T)) = Const (replace_str trm_ss a, T)

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

   112   | replace_aterm trm_ss trm = trm

   113 

   114 fun replace_term trm_ss ty_ss trm =

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

   116 *}

   117 

   118 ML {*

   119 fun get_constrs dts =

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

   121 

   122 fun get_typed_constrs dts =

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

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

   125 

   126 fun get_constr_strs dts =

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

   128 

   129 fun get_bn_fun_strs bn_funs =

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

   131 *}

   132 

   133 ML {*

   134 fun raw_dts_decl dt_names dts lthy =

   135 let

   136   val thy = ProofContext.theory_of lthy

   137   val conf = Datatype.default_config

   138 

   139   val dt_names' = add_raws dt_names

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

   141   val dts' = raw_dts dt_full_names dts

   142 in

   143   lthy

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

   145 end 

   146 *}

   147 

   148 ML {*

   149 fun raw_bn_fun_decl dt_names dts bn_funs bn_eqs lthy =

   150 let

   151   val thy = ProofContext.theory_of lthy

   152 

   153   val dt_names' = add_raws dt_names

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

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

   156   

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

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

   159     (get_typed_constrs dts)

   160 

   161   val bn_fun_strs = get_bn_fun_strs bn_funs

   162   val bn_fun_strs' = add_raws bn_fun_strs

   163   

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

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

   166   

   167   val bn_eqs' = map (fn trm => 

   168     (Attrib.empty_binding, 

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

   170 in

   171   if null bn_eqs 

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

   173   else Primrec.add_primrec bn_funs' bn_eqs' lthy 

   174 end 

   175 *}

   176 

   177 ML {* 

   178 fun nominal_datatype2 dts bn_funs bn_eqs lthy =

   179 let

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

   181 in

   182   lthy

   183   |> raw_dts_decl dts_names dts

   184   ||>> raw_bn_fun_decl dts_names dts bn_funs bn_eqs

   185 end

   186 *}

   187 

   188 ML {*

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

   190 fun mk_type thy bind tvrs =

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

   192 

   193 fun get_constrs2 thy dts =

   194 let

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

   196 in

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

   198 end

   199 *}

   200 

   201 ML {*

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

   203 let

   204   val thy = ProofContext.theory_of lthy

   205 

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

   207 

   208   (* adding the types for parsing datatypes *)

   209   val lthy_tmp = lthy

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

   211 

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

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

   214   

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

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

   217 

   218   (* parsing the datatypes *)

   219   val dts_prep = map (prep_dt lthy_tmp) dt_strs

   220 

   221   (* adding constructors for parsing functions *)

   222   val lthy_tmp2 = lthy_tmp

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

   224 

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

   226 

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

   228 

   229   fun prep_bn_eq (attr, t) = t

   230 

   231   val bn_fun_prep = map prep_bn_fun bn_fun_aux

   232   val bn_eq_prep = map prep_bn_eq bn_eq_aux 

   233 

   234 in

   235   nominal_datatype2 dts_prep bn_fun_prep bn_eq_prep lthy |> snd

   236 end

   237 *}

   238 

   239 (* Command Keyword *)

   240 ML {*

   241 let

   242    val kind = OuterKeyword.thy_decl

   243 in

   244    OuterSyntax.local_theory "nominal_datatype" "test" kind 

   245      (main_parser >> nominal_datatype2_cmd)

   246 end

   247 *}

   248 

   249 text {* example 1 *}

   250 

   251 nominal_datatype lam =

   252   VAR "name"

   253 | APP "lam" "lam"

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

   255 and bp = 

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

   257 binder

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

   259 where

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

   261 

   262 typ lam_raw

   263 term VAR_raw

   264 term Test.BP_raw

   265 thm bi_raw.simps

   266 

   267 print_theorems

   268 

   269 text {* examples 2 *}

   270 nominal_datatype trm =

   271   Var "name"

   272 | App "trm" "trm"

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

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

   275 and pat =

   276   PN

   277 | PS "name"

   278 | PD "name" "name"

   279 binder

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

   281 where 

   282   "f PN = {}"

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

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

   285 

   286 thm f_raw.simps

   287 

   288 nominal_datatype trm0 =

   289   Var0 "name"

   290 | App0 "trm0" "trm0"

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

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

   293 and pat0 =

   294   PN0

   295 | PS0 "name"

   296 | PD0 "pat0" "pat0"

   297 binder

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

   299 where 

   300   "f0 PN0 = {}"

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

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

   303 

   304 thm f0_raw.simps

   305 

   306 text {* example type schemes *}

   307 datatype ty = 

   308   Var "name" 

   309 | Fun "ty" "ty"

   310 

   311 nominal_datatype tyS = 

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

   313 

   314 

   315 

   316 (* example 1 from Terms.thy *)

   317 

   318 nominal_datatype trm1 =

   319   Vr1 "name"

   320 | Ap1 "trm1" "trm1"

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

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

   323 and bp1 =

   324   BUnit1

   325 | BV1 "name"

   326 | BP1 "bp1" "bp1"

   327 binder

   328   bv1

   329 where

   330   "bv1 (BUnit1) = {}"

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

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

   333 

   334 thm bv1_raw.simps

   335 

   336 (* example 2 from Terms.thy *)

   337 

   338 nominal_datatype trm2 =

   339   Vr2 "name"

   340 | Ap2 "trm2" "trm2"

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

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

   343 and rassign = 

   344   As "name" "trm2"

   345 binder

   346   bv2

   347 where

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

   349 

   350 (* example 3 from Terms.thy *)

   351 

   352 nominal_datatype trm3 =

   353   Vr3 "name"

   354 | Ap3 "trm3" "trm3"

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

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

   357 and rassigns3 =

   358   ANil

   359 | ACons "name" "trm3" "rassigns3"

   360 binder

   361   bv3

   362 where

   363   "bv3 ANil = {}"

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

   365 

   366 (* example 4 from Terms.thy *)

   367 

   368 nominal_datatype trm4 =

   369   Vr4 "name"

   370 | Ap4 "trm4" "trm4 list"

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

   372 

   373 (* example 5 from Terms.thy *)

   374 

   375 nominal_datatype trm5 =

   376   Vr5 "name"

   377 | Ap5 "trm5" "trm5"

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

   379 and lts =

   380   Lnil

   381 | Lcons "name" "trm5" "lts"

   382 binder

   383   bv5

   384 where

   385   "bv5 Lnil = {}"

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

   387 

   388 (* example 6 from Terms.thy *)

   389 

   390 nominal_datatype trm6 =

   391   Vr6 "name"

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

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

   394 binder

   395   bv6

   396 where

   397   "bv6 (Vr6 n) = {}"

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

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

   400 

   401 (* example 7 from Terms.thy *)

   402 

   403 nominal_datatype trm7 =

   404   Vr7 "name"

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

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

   407 binder 

   408   bv7 

   409 where

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

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

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

   413 

   414 (* example 8 from Terms.thy *)

   415 

   416 nominal_datatype foo8 =

   417   Foo0 "name"

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

   419 and bar8 =

   420   Bar0 "name"

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

   422 binder 

   423   bv8

   424 where

   425   "bv8 (Bar0 x) = {}"

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

   427 

   428 (* example 9 from Terms.thy *)

   429 

   430 nominal_datatype lam9 =

   431   Var9 "name"

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

   433 and bla9 =

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

   435 binder

   436   bv9

   437 where

   438   "bv9 (Var9 x) = {}"

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

   440 

   441 end

   442 

   443 

   444