1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/src/Tools/Code/code_namespace.ML Wed Sep 01 12:01:19 2010 +0200
1.3 @@ -0,0 +1,129 @@
1.4 +(* Title: Tools/Code/code_namespace.ML
1.5 + Author: Florian Haftmann, TU Muenchen
1.6 +
1.7 +Mastering target language namespaces.
1.8 +*)
1.9 +
1.10 +signature CODE_NAMESPACE =
1.11 +sig
1.12 + datatype 'a node =
1.13 + Dummy
1.14 + | Stmt of Code_Thingol.stmt
1.15 + | Module of ('a * (string * 'a node) Graph.T);
1.16 + val hierarchical_program: (string -> string) -> { module_alias: string -> string option,
1.17 + reserved: Name.context, empty_nsp: 'b, namify_module: string -> 'b -> string * 'b,
1.18 + namify_stmt: Code_Thingol.stmt -> string -> 'b -> string * 'b,
1.19 + cyclic_modules: bool, empty_data: 'a, memorize_data: string -> 'a -> 'a }
1.20 + -> Code_Thingol.program
1.21 + -> { deresolver: string list -> string -> string,
1.22 + hierarchical_program: (string * 'a node) Graph.T }
1.23 +end;
1.24 +
1.25 +structure Code_Namespace : CODE_NAMESPACE =
1.26 +struct
1.27 +
1.28 +(* hierarchical program structure *)
1.29 +
1.30 +datatype 'a node =
1.31 + Dummy
1.32 + | Stmt of Code_Thingol.stmt
1.33 + | Module of ('a * (string * 'a node) Graph.T);
1.34 +
1.35 +fun hierarchical_program labelled_name { module_alias, reserved, empty_nsp,
1.36 + namify_module, namify_stmt, cyclic_modules, empty_data, memorize_data } program =
1.37 + let
1.38 +
1.39 + (* building module name hierarchy *)
1.40 + fun alias_fragments name = case module_alias name
1.41 + of SOME name' => Long_Name.explode name'
1.42 + | NONE => map (fn name => fst (yield_singleton Name.variants name reserved))
1.43 + (Long_Name.explode name);
1.44 + val module_names = Graph.fold (insert (op =) o fst o Code_Printer.dest_name o fst) program [];
1.45 + val fragments_tab = fold (fn name => Symtab.update
1.46 + (name, alias_fragments name)) module_names Symtab.empty;
1.47 + val dest_name = Code_Printer.dest_name #>> (the o Symtab.lookup fragments_tab);
1.48 +
1.49 + (* building empty module hierarchy *)
1.50 + val empty_module = (empty_data, Graph.empty);
1.51 + fun map_module f (Module content) = Module (f content);
1.52 + fun change_module [] = I
1.53 + | change_module (name_fragment :: name_fragments) =
1.54 + apsnd o Graph.map_node name_fragment o apsnd o map_module
1.55 + o change_module name_fragments;
1.56 + fun ensure_module name_fragment (data, nodes) =
1.57 + if can (Graph.get_node nodes) name_fragment then (data, nodes)
1.58 + else (data,
1.59 + nodes |> Graph.new_node (name_fragment, (name_fragment, Module empty_module)));
1.60 + fun allocate_module [] = I
1.61 + | allocate_module (name_fragment :: name_fragments) =
1.62 + ensure_module name_fragment
1.63 + #> (apsnd o Graph.map_node name_fragment o apsnd o map_module o allocate_module) name_fragments;
1.64 + val empty_program = Symtab.fold (fn (_, fragments) => allocate_module fragments)
1.65 + fragments_tab empty_module;
1.66 +
1.67 + (* distribute statements over hierarchy *)
1.68 + fun add_stmt name stmt =
1.69 + let
1.70 + val (name_fragments, base) = dest_name name;
1.71 + in
1.72 + change_module name_fragments (fn (data, nodes) =>
1.73 + (memorize_data name data, Graph.new_node (name, (base, Stmt stmt)) nodes))
1.74 + end;
1.75 + fun add_dependency name name' =
1.76 + let
1.77 + val (name_fragments, base) = dest_name name;
1.78 + val (name_fragments', base') = dest_name name';
1.79 + val (name_fragments_common, (diff, diff')) =
1.80 + chop_prefix (op =) (name_fragments, name_fragments');
1.81 + val (is_module, dep) = if null diff then (false, (name, name'))
1.82 + else (true, (hd diff, hd diff'))
1.83 + val add_edge = if is_module andalso not cyclic_modules
1.84 + then (fn node => Graph.add_edge_acyclic dep node
1.85 + handle Graph.CYCLES _ => error ("Dependency "
1.86 + ^ quote name ^ " -> " ^ quote name'
1.87 + ^ " would result in module dependency cycle"))
1.88 + else Graph.add_edge dep
1.89 + in (change_module name_fragments_common o apsnd) add_edge end;
1.90 + val proto_program = empty_program
1.91 + |> Graph.fold (fn (name, (stmt, _)) => add_stmt name stmt) program
1.92 + |> Graph.fold (fn (name, (_, (_, names))) => fold (add_dependency name) names) program;
1.93 +
1.94 + (* name declarations *)
1.95 + fun make_declarations nsps (data, nodes) =
1.96 + let
1.97 + val (module_fragments, stmt_names) = List.partition
1.98 + (fn name_fragment => case Graph.get_node nodes name_fragment
1.99 + of (_, Module _) => true | _ => false) (Graph.keys nodes);
1.100 + fun modify_stmt (Stmt (Code_Thingol.Datatypecons _)) = Dummy
1.101 + | modify_stmt (Stmt (Code_Thingol.Classrel _)) = Dummy
1.102 + | modify_stmt (Stmt (Code_Thingol.Classparam _)) = Dummy
1.103 + | modify_stmt stmt = stmt;
1.104 + fun declare namify modify name (nsps, nodes) =
1.105 + let
1.106 + val (base, node) = Graph.get_node nodes name;
1.107 + val (base', nsps') = namify node base nsps;
1.108 + val nodes' = Graph.map_node name (K (base', modify node)) nodes;
1.109 + in (nsps', nodes') end;
1.110 + val (nsps', nodes') = (nsps, nodes)
1.111 + |> fold (declare (K namify_module) I) module_fragments
1.112 + |> fold (declare (namify_stmt o (fn Stmt stmt => stmt)) modify_stmt) stmt_names;
1.113 + val nodes'' = nodes'
1.114 + |> fold (fn name_fragment => (Graph.map_node name_fragment
1.115 + o apsnd o map_module) (make_declarations nsps')) module_fragments;
1.116 + in (data, nodes'') end;
1.117 + val (_, hierarchical_program) = make_declarations empty_nsp proto_program;
1.118 +
1.119 + (* deresolving *)
1.120 + fun deresolver prefix_fragments name =
1.121 + let
1.122 + val (name_fragments, _) = dest_name name;
1.123 + val (_, (_, remainder)) = chop_prefix (op =) (prefix_fragments, name_fragments);
1.124 + val nodes = fold (fn name_fragment => fn nodes => case Graph.get_node nodes name_fragment
1.125 + of (_, Module (_, nodes)) => nodes) name_fragments hierarchical_program;
1.126 + val (base', _) = Graph.get_node nodes name;
1.127 + in Long_Name.implode (remainder @ [base']) end
1.128 + handle Graph.UNDEF _ => error ("Unknown statement name: " ^ labelled_name name);
1.129 +
1.130 + in { deresolver = deresolver, hierarchical_program = hierarchical_program } end;
1.131 +
1.132 +end;
1.133 \ No newline at end of file