--- 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));