1.1 --- a/src/Tools/Code/code_haskell.ML	Tue Sep 07 16:05:20 2010 +0200
     1.2 +++ b/src/Tools/Code/code_haskell.ML	Tue Sep 07 16:26:14 2010 +0200
     1.3 @@ -261,77 +261,6 @@
     1.4            end;
     1.5    in print_stmt end;
     1.6  
     1.7 -type flat_program = ((string * Code_Thingol.stmt option) Graph.T * string list) Graph.T;
     1.8 -
     1.9 -fun flat_program labelled_name { module_alias, module_prefix, reserved,
    1.10 -      empty_nsp, namify_stmt, modify_stmt } program =
    1.11 -  let
    1.12 -
    1.13 -    (* building module name hierarchy *)
    1.14 -    val fragments_tab = Code_Namespace.build_module_namespace { module_alias = module_alias,
    1.15 -      module_prefix = module_prefix, reserved = reserved } program;
    1.16 -    val dest_name = Code_Namespace.dest_name
    1.17 -      #>> (Long_Name.implode o the o Symtab.lookup fragments_tab);
    1.18 -
    1.19 -    (* distribute statements over hierarchy *)
    1.20 -    fun add_stmt name stmt =
    1.21 -      let
    1.22 -        val (module_name, base) = dest_name name;
    1.23 -      in
    1.24 -        Graph.default_node (module_name, (Graph.empty, []))
    1.25 -        #> (Graph.map_node module_name o apfst) (Graph.new_node (name, (base, stmt)))
    1.26 -      end;
    1.27 -    fun add_dependency name name' =
    1.28 -      let
    1.29 -        val (module_name, base) = dest_name name;
    1.30 -        val (module_name', base') = dest_name name';
    1.31 -      in if module_name = module_name'
    1.32 -        then (Graph.map_node module_name o apfst) (Graph.add_edge (name, name'))
    1.33 -        else (Graph.map_node module_name o apsnd) (AList.map_default (op =) (module_name', []) (insert (op =) name'))
    1.34 -      end;
    1.35 -    val proto_program = Graph.empty
    1.36 -      |> Graph.fold (fn (name, (stmt, _)) => add_stmt name stmt) program
    1.37 -      |> Graph.fold (fn (name, (_, (_, names))) => fold (add_dependency name) names) program;
    1.38 -
    1.39 -    (* name declarations and statement modifications *)
    1.40 -    fun declare name (base, stmt) (gr, nsp) = 
    1.41 -      let
    1.42 -        val (base', nsp') = namify_stmt stmt base nsp;
    1.43 -        val gr' = (Graph.map_node name o apfst) (K base') gr;
    1.44 -      in (gr', nsp') end;
    1.45 -    fun declarations gr = (gr, empty_nsp)
    1.46 -      |> fold (fn name => declare name (Graph.get_node gr name)) (Graph.keys gr) 
    1.47 -      |> fst
    1.48 -      |> (Graph.map o K o apsnd) modify_stmt;
    1.49 -    val flat_program = proto_program
    1.50 -      |> (Graph.map o K o apfst) declarations;
    1.51 -
    1.52 -    (* qualified and unqualified imports, deresolving *)
    1.53 -    fun base_deresolver name = fst (Graph.get_node
    1.54 -      (fst (Graph.get_node flat_program (fst (dest_name name)))) name);
    1.55 -    fun classify_names gr imports =
    1.56 -      let
    1.57 -        val import_tab = maps
    1.58 -          (fn (module_name, names) => map (rpair module_name) names) imports;
    1.59 -        val imported_names = map fst import_tab;
    1.60 -        val here_names = Graph.keys gr;
    1.61 -      in
    1.62 -        Symtab.empty
    1.63 -        |> fold (fn name => Symtab.update (name, base_deresolver name)) here_names
    1.64 -        |> fold (fn name => Symtab.update (name,
    1.65 -            Long_Name.append (the (AList.lookup (op =) import_tab name))
    1.66 -              (base_deresolver name))) imported_names
    1.67 -      end;
    1.68 -    val name_tabs = AList.make (uncurry classify_names o Graph.get_node flat_program)
    1.69 -      (Graph.keys flat_program);
    1.70 -    val deresolver_tab = Symtab.empty
    1.71 -      |> fold (fn (module_name, name_tab) => Symtab.update (module_name, name_tab)) name_tabs;
    1.72 -    fun deresolver module_name name =
    1.73 -      the (Symtab.lookup (the (Symtab.lookup deresolver_tab module_name)) name)
    1.74 -      handle Option => error ("Unknown statement name: " ^ labelled_name name);
    1.75 -
    1.76 -  in { deresolver = deresolver, flat_program = flat_program } end;
    1.77 -
    1.78  fun haskell_program_of_program labelled_name module_alias module_prefix reserved =
    1.79    let
    1.80      fun namify_fun upper base (nsp_fun, nsp_typ) =
    1.81 @@ -361,7 +290,7 @@
    1.82        | select_stmt (Code_Thingol.Classparam _) = false
    1.83        | select_stmt (Code_Thingol.Classinst _) = true;
    1.84    in
    1.85 -    flat_program labelled_name
    1.86 +    Code_Namespace.flat_program labelled_name
    1.87        { module_alias = module_alias, module_prefix = module_prefix,
    1.88          reserved = reserved, empty_nsp = (reserved, reserved), namify_stmt = namify_stmt,
    1.89          modify_stmt = fn stmt => if select_stmt stmt then SOME stmt else NONE }
    1.90 @@ -440,7 +369,7 @@
    1.91    end;
    1.92  
    1.93  val serializer : Code_Target.serializer =
    1.94 -  Code_Target.parse_args (Scan.option (Args.$$$ "root" -- Args.colon |-- Args.name)
    1.95 +  Code_Target.parse_args (Scan.optional (Args.$$$ "root" -- Args.colon |-- Args.name) ""
    1.96      -- Scan.optional (Args.$$$ "string_classes" >> K true) false
    1.97      >> (fn (module_prefix, string_classes) =>
    1.98        serialize_haskell module_prefix string_classes));