
diff -r 9df6144e281b -r 853abc14c5c6 Nominal/Test.thy
--- a/Nominal/Test.thy	Thu Feb 25 07:57:17 2010 +0100
+++ b/Nominal/Test.thy	Thu Feb 25 08:40:52 2010 +0100
@@ -1,238 +1,7 @@
 theory Test
-imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp"
+imports "Parser"
 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 =
@@ -253,7 +22,8 @@
 
 print_theorems
 
-text {* examples 2 *}
+text {* example 2 *}
+
 nominal_datatype trm =
   Var "name"
 | App "trm" "trm"




