1.1 --- a/src/Tools/Code/code_haskell.ML Mon Sep 06 12:38:45 2010 +0200
1.2 +++ b/src/Tools/Code/code_haskell.ML Tue Sep 07 11:08:57 2010 +0200
1.3 @@ -261,23 +261,129 @@
1.4 end;
1.5 in print_stmt end;
1.6
1.7 +type flat_program = ((string * Code_Thingol.stmt) Graph.T * ((string * (string list * string list)) 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 case modify_stmt stmt
1.24 + of SOME stmt' =>
1.25 + Graph.default_node (module_name, (Graph.empty, []))
1.26 + #> (Graph.map_node module_name o apfst) (Graph.new_node (name, (base, stmt')))
1.27 + | NONE => I
1.28 + end;
1.29 + fun add_dependency name name' =
1.30 + let
1.31 + val (module_name, base) = dest_name name;
1.32 + val (module_name', base') = dest_name name';
1.33 + in if module_name = module_name'
1.34 + then (Graph.map_node module_name o apfst) (Graph.add_edge (name, name'))
1.35 + else (Graph.map_node module_name o apsnd)
1.36 + (AList.map_default (op =) (module_name', []) (insert (op =) name'))
1.37 + end;
1.38 + val proto_program = Graph.empty
1.39 + |> Graph.fold (fn (name, (stmt, _)) => add_stmt name stmt) program
1.40 + |> Graph.fold (fn (name, (_, (_, names))) => fold (add_dependency name) names) program;
1.41 +
1.42 + (* name declarations *)
1.43 + fun declare name (base, stmt) (gr, nsp) =
1.44 + let
1.45 + val (base', nsp') = namify_stmt stmt base nsp;
1.46 + val gr' = (Graph.map_node name o apfst) (K base') gr;
1.47 + in (gr', nsp') end;
1.48 + fun declarations gr = (gr, empty_nsp)
1.49 + |> fold (fn name => declare name (Graph.get_node gr name)) (Graph.keys gr)
1.50 + |> fst;
1.51 + val intermediate_program = proto_program
1.52 + |> Graph.map ((K o apfst) declarations);
1.53 +
1.54 + (* qualified and unqualified imports, deresolving *)
1.55 + fun base_deresolver name = fst (Graph.get_node
1.56 + (fst (Graph.get_node intermediate_program (fst (dest_name name)))) name);
1.57 + fun classify_imports gr imports =
1.58 + let
1.59 + val import_tab = maps
1.60 + (fn (module_name, names) => map (rpair module_name) names) imports;
1.61 + val imported_names = map fst import_tab;
1.62 + val here_names = Graph.keys gr;
1.63 + val qualified_names = []
1.64 + |> fold (fn name => AList.map_default (op =) (base_deresolver name, [])
1.65 + (insert (op =) name)) (here_names @ imported_names)
1.66 + |> filter (fn (_, names) => length names > 1)
1.67 + |> maps snd;
1.68 + val name_tab = Symtab.empty
1.69 + |> fold (fn name => Symtab.update (name, base_deresolver name)) here_names
1.70 + |> fold (fn name => Symtab.update (name,
1.71 + if member (op =) qualified_names name
1.72 + then Long_Name.append (the (AList.lookup (op =) import_tab name))
1.73 + (base_deresolver name)
1.74 + else base_deresolver name)) imported_names;
1.75 + val imports' = (map o apsnd) (List.partition (member (op =) qualified_names))
1.76 + imports;
1.77 + in (name_tab, imports') end;
1.78 + val classified = AList.make (uncurry classify_imports o Graph.get_node intermediate_program)
1.79 + (Graph.keys intermediate_program);
1.80 + val flat_program = Graph.map (apsnd o K o snd o the o AList.lookup (op =) classified)
1.81 + intermediate_program;
1.82 + val deresolver_tab = Symtab.empty
1.83 + |> fold (fn (module_name, (name_tab, _)) => Symtab.update (module_name, name_tab)) classified;
1.84 + fun deresolver module_name name =
1.85 + the (Symtab.lookup (the (Symtab.lookup deresolver_tab module_name)) name)
1.86 + handle Option => error ("Unknown statement name: " ^ labelled_name name);
1.87 +
1.88 + in (deresolver, flat_program) end;
1.89 +
1.90 +fun haskell_program_of_program labelled_name module_alias module_prefix reserved =
1.91 + let
1.92 + fun namify_fun upper base (nsp_fun, nsp_typ) =
1.93 + let
1.94 + val (base', nsp_fun') = yield_singleton Name.variants
1.95 + (if upper then first_upper base else base) nsp_fun;
1.96 + in (base', (nsp_fun', nsp_typ)) end;
1.97 + fun namify_typ base (nsp_fun, nsp_typ) =
1.98 + let
1.99 + val (base', nsp_typ') = yield_singleton Name.variants
1.100 + (first_upper base) nsp_typ
1.101 + in (base', (nsp_fun, nsp_typ')) end;
1.102 + fun namify_stmt (Code_Thingol.Fun (_, (_, SOME _))) = pair
1.103 + | namify_stmt (Code_Thingol.Fun _) = namify_fun false
1.104 + | namify_stmt (Code_Thingol.Datatype _) = namify_typ
1.105 + | namify_stmt (Code_Thingol.Datatypecons _) = namify_fun true
1.106 + | namify_stmt (Code_Thingol.Class _) = namify_typ
1.107 + | namify_stmt (Code_Thingol.Classrel _) = pair
1.108 + | namify_stmt (Code_Thingol.Classparam _) = namify_fun false
1.109 + | namify_stmt (Code_Thingol.Classinst _) = pair;
1.110 + fun select_stmt (Code_Thingol.Fun (_, (_, SOME _))) = false
1.111 + | select_stmt (Code_Thingol.Fun _) = true
1.112 + | select_stmt (Code_Thingol.Datatype _) = true
1.113 + | select_stmt (Code_Thingol.Datatypecons _) = false
1.114 + | select_stmt (Code_Thingol.Class _) = true
1.115 + | select_stmt (Code_Thingol.Classrel _) = false
1.116 + | select_stmt (Code_Thingol.Classparam _) = false
1.117 + | select_stmt (Code_Thingol.Classinst _) = true;
1.118 + in
1.119 + flat_program labelled_name
1.120 + { module_alias = module_alias, module_prefix = module_prefix,
1.121 + reserved = reserved, empty_nsp = (reserved, reserved), namify_stmt = namify_stmt,
1.122 + modify_stmt = fn stmt => if select_stmt stmt then SOME stmt else NONE }
1.123 + end;
1.124 +
1.125 fun mk_name_module reserved module_prefix module_alias program =
1.126 let
1.127 - fun mk_alias name = case module_alias name
1.128 - of SOME name' => name'
1.129 - | NONE => name
1.130 - |> Long_Name.explode
1.131 - |> map (fn name => (the_single o fst) (Name.variants [name] reserved))
1.132 - |> Long_Name.implode;
1.133 - fun mk_prefix name = case module_prefix
1.134 - of SOME module_prefix => Long_Name.append module_prefix name
1.135 - | NONE => name;
1.136 - val tab =
1.137 - Symtab.empty
1.138 - |> Graph.fold ((fn name => Symtab.default (name, (mk_alias #> mk_prefix) name))
1.139 - o fst o Code_Namespace.dest_name o fst)
1.140 - program
1.141 - in the o Symtab.lookup tab end;
1.142 + val fragments_tab = Code_Namespace.build_module_namespace { module_alias = module_alias,
1.143 + module_prefix = module_prefix, reserved = reserved } program;
1.144 + in Long_Name.implode o the o Symtab.lookup fragments_tab end;
1.145
1.146 fun haskell_program_of_program labelled_name module_prefix reserved module_alias program =
1.147 let