--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Nominal/Test.thy Thu Feb 25 07:48:33 2010 +0100
@@ -0,0 +1,431 @@
+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
+
+
+