# HG changeset patch
# User haftmann
# Date 1283869574 -7200
# Node ID 303b63be1a9dbc514da500bd03f047c2c78d95a2
# Parent  13c6e91efcb671f21ec2401155455b5a915b99ba
moved flat_program to code_namespace

diff -r 13c6e91efcb6 -r 303b63be1a9d src/Tools/Code/code_haskell.ML
--- a/src/Tools/Code/code_haskell.ML	Tue Sep 07 16:05:20 2010 +0200
+++ b/src/Tools/Code/code_haskell.ML	Tue Sep 07 16:26:14 2010 +0200
@@ -261,77 +261,6 @@
           end;
   in print_stmt end;
 
-type flat_program = ((string * Code_Thingol.stmt option) Graph.T * string list) Graph.T;
-
-fun flat_program labelled_name { module_alias, module_prefix, reserved,
-      empty_nsp, namify_stmt, modify_stmt } program =
-  let
-
-    (* building module name hierarchy *)
-    val fragments_tab = Code_Namespace.build_module_namespace { module_alias = module_alias,
-      module_prefix = module_prefix, reserved = reserved } program;
-    val dest_name = Code_Namespace.dest_name
-      #>> (Long_Name.implode o the o Symtab.lookup fragments_tab);
-
-    (* distribute statements over hierarchy *)
-    fun add_stmt name stmt =
-      let
-        val (module_name, base) = dest_name name;
-      in
-        Graph.default_node (module_name, (Graph.empty, []))
-        #> (Graph.map_node module_name o apfst) (Graph.new_node (name, (base, stmt)))
-      end;
-    fun add_dependency name name' =
-      let
-        val (module_name, base) = dest_name name;
-        val (module_name', base') = dest_name name';
-      in if module_name = module_name'
-        then (Graph.map_node module_name o apfst) (Graph.add_edge (name, name'))
-        else (Graph.map_node module_name o apsnd) (AList.map_default (op =) (module_name', []) (insert (op =) name'))
-      end;
-    val proto_program = Graph.empty
-      |> Graph.fold (fn (name, (stmt, _)) => add_stmt name stmt) program
-      |> Graph.fold (fn (name, (_, (_, names))) => fold (add_dependency name) names) program;
-
-    (* name declarations and statement modifications *)
-    fun declare name (base, stmt) (gr, nsp) = 
-      let
-        val (base', nsp') = namify_stmt stmt base nsp;
-        val gr' = (Graph.map_node name o apfst) (K base') gr;
-      in (gr', nsp') end;
-    fun declarations gr = (gr, empty_nsp)
-      |> fold (fn name => declare name (Graph.get_node gr name)) (Graph.keys gr) 
-      |> fst
-      |> (Graph.map o K o apsnd) modify_stmt;
-    val flat_program = proto_program
-      |> (Graph.map o K o apfst) declarations;
-
-    (* qualified and unqualified imports, deresolving *)
-    fun base_deresolver name = fst (Graph.get_node
-      (fst (Graph.get_node flat_program (fst (dest_name name)))) name);
-    fun classify_names gr imports =
-      let
-        val import_tab = maps
-          (fn (module_name, names) => map (rpair module_name) names) imports;
-        val imported_names = map fst import_tab;
-        val here_names = Graph.keys gr;
-      in
-        Symtab.empty
-        |> fold (fn name => Symtab.update (name, base_deresolver name)) here_names
-        |> fold (fn name => Symtab.update (name,
-            Long_Name.append (the (AList.lookup (op =) import_tab name))
-              (base_deresolver name))) imported_names
-      end;
-    val name_tabs = AList.make (uncurry classify_names o Graph.get_node flat_program)
-      (Graph.keys flat_program);
-    val deresolver_tab = Symtab.empty
-      |> fold (fn (module_name, name_tab) => Symtab.update (module_name, name_tab)) name_tabs;
-    fun deresolver module_name name =
-      the (Symtab.lookup (the (Symtab.lookup deresolver_tab module_name)) name)
-      handle Option => error ("Unknown statement name: " ^ labelled_name name);
-
-  in { deresolver = deresolver, flat_program = flat_program } end;
-
 fun haskell_program_of_program labelled_name module_alias module_prefix reserved =
   let
     fun namify_fun upper base (nsp_fun, nsp_typ) =
@@ -361,7 +290,7 @@
       | select_stmt (Code_Thingol.Classparam _) = false
       | select_stmt (Code_Thingol.Classinst _) = true;
   in
-    flat_program labelled_name
+    Code_Namespace.flat_program labelled_name
       { module_alias = module_alias, module_prefix = module_prefix,
         reserved = reserved, empty_nsp = (reserved, reserved), namify_stmt = namify_stmt,
         modify_stmt = fn stmt => if select_stmt stmt then SOME stmt else NONE }
@@ -440,7 +369,7 @@
   end;
 
 val serializer : Code_Target.serializer =
-  Code_Target.parse_args (Scan.option (Args.$$$ "root" -- Args.colon |-- Args.name)
+  Code_Target.parse_args (Scan.optional (Args.$$$ "root" -- Args.colon |-- Args.name) ""
     -- Scan.optional (Args.$$$ "string_classes" >> K true) false
     >> (fn (module_prefix, string_classes) =>
       serialize_haskell module_prefix string_classes));