haftmann@38970: (* Title: Tools/Code/code_namespace.ML haftmann@38970: Author: Florian Haftmann, TU Muenchen haftmann@38970: haftmann@38970: Mastering target language namespaces. haftmann@38970: *) haftmann@38970: haftmann@38970: signature CODE_NAMESPACE = haftmann@38970: sig haftmann@39208: type flat_program haftmann@39208: val flat_program: (string -> string) -> { module_alias: string -> string option, haftmann@39208: module_prefix: string, reserved: Name.context, empty_nsp: 'a, haftmann@39208: namify_stmt: Code_Thingol.stmt -> string -> 'a -> string * 'a, haftmann@39208: modify_stmt: Code_Thingol.stmt -> Code_Thingol.stmt option } haftmann@39208: -> Code_Thingol.program haftmann@39208: -> { deresolver: string -> string -> string, haftmann@39208: flat_program: flat_program } haftmann@39208: haftmann@39017: datatype ('a, 'b) node = haftmann@38970: Dummy haftmann@39017: | Stmt of 'a haftmann@39147: | Module of ('b * (string * ('a, 'b) node) Graph.T) haftmann@39208: type ('a, 'b) hierarchical_program haftmann@38970: val hierarchical_program: (string -> string) -> { module_alias: string -> string option, haftmann@39022: reserved: Name.context, empty_nsp: 'c, namify_module: string -> 'c -> string * 'c, haftmann@39022: namify_stmt: Code_Thingol.stmt -> string -> 'c -> string * 'c, haftmann@39022: cyclic_modules: bool, empty_data: 'b, memorize_data: string -> 'b -> 'b, haftmann@39024: modify_stmts: (string * Code_Thingol.stmt) list -> 'a option list } haftmann@38970: -> Code_Thingol.program haftmann@38970: -> { deresolver: string list -> string -> string, haftmann@39147: hierarchical_program: ('a, 'b) hierarchical_program } haftmann@39147: val print_hierarchical: { print_module: string list -> string -> 'b -> 'c list -> 'c, haftmann@39147: print_stmt: string list -> string * 'a -> 'c, haftmann@39147: lift_markup: (Pretty.T -> Pretty.T) -> 'c -> 'c } haftmann@39147: -> ('a, 'b) hierarchical_program -> 'c list haftmann@38970: end; haftmann@38970: haftmann@38970: structure Code_Namespace : CODE_NAMESPACE = haftmann@38970: struct haftmann@38970: haftmann@39203: (** building module name hierarchy **) haftmann@39055: haftmann@39055: val dest_name = haftmann@39055: apfst Long_Name.implode o split_last o fst o split_last o Long_Name.explode; haftmann@39055: haftmann@39203: fun build_module_namespace { module_alias, module_prefix, reserved } program = haftmann@39203: let haftmann@39203: fun alias_fragments name = case module_alias name haftmann@39203: of SOME name' => Long_Name.explode name' wenzelm@43326: | NONE => map (fn name => fst (Name.variant name reserved)) (Long_Name.explode name); haftmann@39203: val module_names = Graph.fold (insert (op =) o fst o dest_name o fst) program []; haftmann@39203: in haftmann@39208: fold (fn name => Symtab.update (name, Long_Name.explode module_prefix @ alias_fragments name)) haftmann@39203: module_names Symtab.empty haftmann@39203: end; haftmann@39203: haftmann@39055: haftmann@39208: (** flat program structure **) haftmann@39208: haftmann@39208: type flat_program = ((string * Code_Thingol.stmt option) Graph.T * (string * string list) list) Graph.T; haftmann@39208: haftmann@39208: fun flat_program labelled_name { module_alias, module_prefix, reserved, haftmann@39208: empty_nsp, namify_stmt, modify_stmt } program = haftmann@39208: let haftmann@39208: haftmann@39208: (* building module name hierarchy *) haftmann@39208: val fragments_tab = build_module_namespace { module_alias = module_alias, haftmann@39208: module_prefix = module_prefix, reserved = reserved } program; haftmann@39208: val dest_name = dest_name haftmann@39208: #>> (Long_Name.implode o the o Symtab.lookup fragments_tab); haftmann@39208: haftmann@39208: (* distribute statements over hierarchy *) haftmann@39208: fun add_stmt name stmt = haftmann@39208: let haftmann@39208: val (module_name, base) = dest_name name; haftmann@39208: in haftmann@39208: Graph.default_node (module_name, (Graph.empty, [])) haftmann@39208: #> (Graph.map_node module_name o apfst) (Graph.new_node (name, (base, stmt))) haftmann@39208: end; haftmann@39208: fun add_dependency name name' = haftmann@39208: let haftmann@47576: val (module_name, _) = dest_name name; haftmann@47576: val (module_name', _) = dest_name name'; haftmann@39208: in if module_name = module_name' haftmann@39208: then (Graph.map_node module_name o apfst) (Graph.add_edge (name, name')) haftmann@39208: else (Graph.map_node module_name o apsnd) (AList.map_default (op =) (module_name', []) (insert (op =) name')) haftmann@39208: end; haftmann@39208: val proto_program = Graph.empty haftmann@39208: |> Graph.fold (fn (name, (stmt, _)) => add_stmt name stmt) program wenzelm@44338: |> Graph.fold (fn (name, (_, (_, names))) => wenzelm@44338: Graph.Keys.fold (add_dependency name) names) program; haftmann@39208: haftmann@39208: (* name declarations and statement modifications *) haftmann@39208: fun declare name (base, stmt) (gr, nsp) = haftmann@39208: let haftmann@39208: val (base', nsp') = namify_stmt stmt base nsp; haftmann@39208: val gr' = (Graph.map_node name o apfst) (K base') gr; haftmann@39208: in (gr', nsp') end; haftmann@39208: fun declarations gr = (gr, empty_nsp) haftmann@39208: |> fold (fn name => declare name (Graph.get_node gr name)) (Graph.keys gr) haftmann@39208: |> fst haftmann@39208: |> (Graph.map o K o apsnd) modify_stmt; haftmann@39208: val flat_program = proto_program haftmann@39208: |> (Graph.map o K o apfst) declarations; haftmann@39208: haftmann@39208: (* qualified and unqualified imports, deresolving *) haftmann@39208: fun base_deresolver name = fst (Graph.get_node haftmann@39208: (fst (Graph.get_node flat_program (fst (dest_name name)))) name); haftmann@39208: fun classify_names gr imports = haftmann@39208: let haftmann@39208: val import_tab = maps haftmann@39208: (fn (module_name, names) => map (rpair module_name) names) imports; haftmann@39208: val imported_names = map fst import_tab; haftmann@39208: val here_names = Graph.keys gr; haftmann@39208: in haftmann@39208: Symtab.empty haftmann@39208: |> fold (fn name => Symtab.update (name, base_deresolver name)) here_names haftmann@39208: |> fold (fn name => Symtab.update (name, haftmann@39208: Long_Name.append (the (AList.lookup (op =) import_tab name)) haftmann@39208: (base_deresolver name))) imported_names haftmann@39208: end; haftmann@40630: val deresolver_tab = Symtab.make (AList.make haftmann@40630: (uncurry classify_names o Graph.get_node flat_program) haftmann@40630: (Graph.keys flat_program)); haftmann@40705: fun deresolver "" name = haftmann@40705: Long_Name.append (fst (dest_name name)) (base_deresolver name) haftmann@40705: | deresolver module_name name = haftmann@40705: the (Symtab.lookup (the (Symtab.lookup deresolver_tab module_name)) name) wenzelm@51930: handle Option.Option => error ("Unknown statement name: " ^ labelled_name name); haftmann@39208: haftmann@39208: in { deresolver = deresolver, flat_program = flat_program } end; haftmann@39208: haftmann@39208: haftmann@39055: (** hierarchical program structure **) haftmann@38970: haftmann@39017: datatype ('a, 'b) node = haftmann@38970: Dummy haftmann@39017: | Stmt of 'a haftmann@39017: | Module of ('b * (string * ('a, 'b) node) Graph.T); haftmann@38970: haftmann@39147: type ('a, 'b) hierarchical_program = (string * ('a, 'b) node) Graph.T; haftmann@39147: haftmann@39018: fun map_module_content f (Module content) = Module (f content); haftmann@39018: haftmann@39018: fun map_module [] = I haftmann@39018: | map_module (name_fragment :: name_fragments) = haftmann@39018: apsnd o Graph.map_node name_fragment o apsnd o map_module_content haftmann@39018: o map_module name_fragments; haftmann@39018: haftmann@38970: fun hierarchical_program labelled_name { module_alias, reserved, empty_nsp, haftmann@39023: namify_module, namify_stmt, cyclic_modules, empty_data, memorize_data, modify_stmts } program = haftmann@38970: let haftmann@38970: haftmann@38970: (* building module name hierarchy *) haftmann@39203: val fragments_tab = build_module_namespace { module_alias = module_alias, haftmann@39208: module_prefix = "", reserved = reserved } program; haftmann@39055: val dest_name = dest_name #>> (the o Symtab.lookup fragments_tab); haftmann@38970: haftmann@38970: (* building empty module hierarchy *) haftmann@38970: val empty_module = (empty_data, Graph.empty); haftmann@38970: fun ensure_module name_fragment (data, nodes) = haftmann@38970: if can (Graph.get_node nodes) name_fragment then (data, nodes) haftmann@38970: else (data, haftmann@38970: nodes |> Graph.new_node (name_fragment, (name_fragment, Module empty_module))); haftmann@38970: fun allocate_module [] = I haftmann@38970: | allocate_module (name_fragment :: name_fragments) = haftmann@38970: ensure_module name_fragment haftmann@39018: #> (apsnd o Graph.map_node name_fragment o apsnd o map_module_content o allocate_module) name_fragments; haftmann@38970: val empty_program = Symtab.fold (fn (_, fragments) => allocate_module fragments) haftmann@38970: fragments_tab empty_module; haftmann@38970: haftmann@38970: (* distribute statements over hierarchy *) haftmann@38970: fun add_stmt name stmt = haftmann@38970: let haftmann@38970: val (name_fragments, base) = dest_name name; haftmann@38970: in haftmann@39018: (map_module name_fragments o apsnd) (Graph.new_node (name, (base, Stmt stmt))) haftmann@38970: end; haftmann@38970: fun add_dependency name name' = haftmann@38970: let haftmann@47576: val (name_fragments, _) = dest_name name; haftmann@47576: val (name_fragments', _) = dest_name name'; haftmann@38970: val (name_fragments_common, (diff, diff')) = haftmann@38970: chop_prefix (op =) (name_fragments, name_fragments'); haftmann@39023: val is_module = not (null diff andalso null diff'); haftmann@39023: val dep = pairself hd (diff @ [name], diff' @ [name']); haftmann@38970: val add_edge = if is_module andalso not cyclic_modules haftmann@38970: then (fn node => Graph.add_edge_acyclic dep node haftmann@38970: handle Graph.CYCLES _ => error ("Dependency " haftmann@38970: ^ quote name ^ " -> " ^ quote name' haftmann@38970: ^ " would result in module dependency cycle")) haftmann@38970: else Graph.add_edge dep haftmann@39018: in (map_module name_fragments_common o apsnd) add_edge end; haftmann@38970: val proto_program = empty_program haftmann@38970: |> Graph.fold (fn (name, (stmt, _)) => add_stmt name stmt) program wenzelm@44338: |> Graph.fold (fn (name, (_, (_, names))) => wenzelm@44338: Graph.Keys.fold (add_dependency name) names) program; haftmann@38970: haftmann@39022: (* name declarations, data and statement modifications *) haftmann@38970: fun make_declarations nsps (data, nodes) = haftmann@38970: let haftmann@38970: val (module_fragments, stmt_names) = List.partition haftmann@38970: (fn name_fragment => case Graph.get_node nodes name_fragment haftmann@38970: of (_, Module _) => true | _ => false) (Graph.keys nodes); haftmann@39022: fun declare namify name (nsps, nodes) = haftmann@38970: let haftmann@38970: val (base, node) = Graph.get_node nodes name; haftmann@38970: val (base', nsps') = namify node base nsps; haftmann@39022: val nodes' = Graph.map_node name (K (base', node)) nodes; haftmann@38970: in (nsps', nodes') end; haftmann@38970: val (nsps', nodes') = (nsps, nodes) haftmann@39022: |> fold (declare (K namify_module)) module_fragments haftmann@39022: |> fold (declare (namify_stmt o (fn Stmt stmt => stmt))) stmt_names; haftmann@39029: fun zip_fillup xs ys = xs ~~ ys @ replicate (length xs - length ys) NONE; haftmann@39029: fun select_names names = case filter (member (op =) stmt_names) names haftmann@39029: of [] => NONE haftmann@39029: | xs => SOME xs; haftmann@39029: val modify_stmts' = AList.make (snd o Graph.get_node nodes) haftmann@39023: #> split_list haftmann@39023: ##> map (fn Stmt stmt => stmt) haftmann@39029: #> (fn (names, stmts) => zip_fillup names (modify_stmts (names ~~ stmts))); haftmann@39029: val stmtss' = (maps modify_stmts' o map_filter select_names o Graph.strong_conn) nodes; haftmann@39023: val nodes'' = Graph.map (fn name => apsnd (fn Module content => Module (make_declarations nsps' content) haftmann@39023: | _ => case AList.lookup (op =) stmtss' name of SOME (SOME stmt) => Stmt stmt | _ => Dummy)) nodes'; haftmann@39018: val data' = fold memorize_data stmt_names data; haftmann@39018: in (data', nodes'') end; haftmann@38970: val (_, hierarchical_program) = make_declarations empty_nsp proto_program; haftmann@38970: haftmann@38970: (* deresolving *) haftmann@38970: fun deresolver prefix_fragments name = haftmann@38970: let haftmann@38970: val (name_fragments, _) = dest_name name; haftmann@38970: val (_, (_, remainder)) = chop_prefix (op =) (prefix_fragments, name_fragments); haftmann@38970: val nodes = fold (fn name_fragment => fn nodes => case Graph.get_node nodes name_fragment haftmann@38970: of (_, Module (_, nodes)) => nodes) name_fragments hierarchical_program; haftmann@38970: val (base', _) = Graph.get_node nodes name; haftmann@38970: in Long_Name.implode (remainder @ [base']) end haftmann@38970: handle Graph.UNDEF _ => error ("Unknown statement name: " ^ labelled_name name); haftmann@38970: haftmann@38970: in { deresolver = deresolver, hierarchical_program = hierarchical_program } end; haftmann@38970: haftmann@39147: fun print_hierarchical { print_module, print_stmt, lift_markup } = haftmann@39147: let haftmann@39147: fun print_node _ (_, Dummy) = haftmann@39147: NONE haftmann@39147: | print_node prefix_fragments (name, Stmt stmt) = haftmann@39147: SOME (lift_markup (Code_Printer.markup_stmt name) haftmann@39147: (print_stmt prefix_fragments (name, stmt))) haftmann@39147: | print_node prefix_fragments (name_fragment, Module (data, nodes)) = haftmann@39147: let haftmann@39147: val prefix_fragments' = prefix_fragments @ [name_fragment] haftmann@39147: in haftmann@39147: Option.map (print_module prefix_fragments' haftmann@39147: name_fragment data) (print_nodes prefix_fragments' nodes) haftmann@39147: end haftmann@39147: and print_nodes prefix_fragments nodes = haftmann@39147: let haftmann@39147: val xs = (map_filter (fn name => print_node prefix_fragments haftmann@39147: (name, snd (Graph.get_node nodes name))) o rev o flat o Graph.strong_conn) nodes haftmann@39147: in if null xs then NONE else SOME xs end; haftmann@39147: in these o print_nodes [] end; haftmann@39147: haftmann@38970: end;