Nominal/Parser.thy
changeset 1287 8557af71724e
parent 1285 e3ac56d3b7af
child 1289 02eb0f600630
--- a/Nominal/Parser.thy	Mon Mar 01 11:40:48 2010 +0100
+++ b/Nominal/Parser.thy	Mon Mar 01 14:26:14 2010 +0100
@@ -126,14 +126,11 @@
 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
+  val raw_dts = raw_dts dt_full_names dts
+  val raw_dt_names = add_raws dt_names
 in
-  lthy
-  |> Local_Theory.theory_result (Datatype.add_datatype conf dt_names' dts')
+  (raw_dt_names, raw_dts)
 end 
 *}
 
@@ -171,10 +168,14 @@
 ML {* 
 fun nominal_datatype2 dts bn_funs bn_eqs binds lthy =
 let
+  val conf = Datatype.default_config
   val dts_names = map (fn (_, s, _, _) => Binding.name_of s) dts
+
+  val (raw_dt_names, raw_dts) = raw_dts_decl dts_names dts lthy
+
 in
   lthy
-  |> raw_dts_decl dts_names dts
+  |> Local_Theory.theory_result (Datatype.add_datatype conf raw_dt_names raw_dts)
   ||>> raw_bn_fun_decl dts_names dts bn_funs bn_eqs
 end
 *}
@@ -242,6 +243,7 @@
 *}
 
 ML {*
+(* associates every SOME with the index in the list *)
 fun mk_env xs =
   let
     fun mapp (_: int) [] = []
@@ -256,14 +258,16 @@
 fun env_lookup xs x =
   case AList.lookup (op =) xs x of
     SOME x => x
-  | NONE => error ("cannot find " ^ x ^ " in the binding specification.")  
+  | NONE => error ("cannot find " ^ x ^ " in the binding specification.");
 *}
 
+
+
 ML {*
 fun prepare_binds dt_strs lthy = 
 let
-  fun extract_cnstrs dt_strs =
-    map ((map (fn (_, antys, _, bns) => (antys, bns))) o forth) dt_strs
+  fun extract_annos_binds dt_strs =
+    map ((map (fn (_, antys, _, bns) => (map fst antys, bns))) o forth) dt_strs
 
   fun prep_bn env bn_str =
     case (Syntax.read_term lthy bn_str) of
@@ -271,20 +275,23 @@
      | Const (a, T) $ Free (x, _) => (env_lookup env x, SOME (Const (a, T)))
      | _ => error (bn_str ^ " not allowed as binding specification.");  
  
-  fun prep_typ env (opt_name, _) = 
+  fun prep_typ env opt_name = 
     case opt_name of
       NONE => []
     | SOME x => find_all (op=) env x;
         
-  fun prep_binds (anno_tys, bind_strs) = 
+  (* annos - list of annotation for each type (either NONE or SOME fo a type *)
+  
+  fun prep_binds (annos, bind_strs) = 
   let
-    val env = mk_env (map fst anno_tys)
+    val env = mk_env annos (* for ever label the index *)
     val binds = map (fn (x, y) => (x, prep_bn env y)) bind_strs  
   in
-    map (prep_typ binds) anno_tys
+    map (prep_typ binds) annos
   end
+
 in
-  map (map prep_binds) (extract_cnstrs dt_strs)
+  map (map prep_binds) (extract_annos_binds dt_strs)
 end
 *}