topology.ml

(* Time-stamp: <modified the 07/06/2019 (at 16:45) by Erwan Jahier> *)

open Graph
open Graph.Dot_ast

type node_id = string
type node = {
  id: node_id;
  file: string;
  init: (string * string) list; 
}


type t = {
  nodes: node list;
  succ: node_id -> node_id list;
  of_id: node_id -> node;
}

type node_info_t = (string, node) Hashtbl.t
let node_info:node_info_t = Hashtbl.create 100

type node_succ_t = (string, string list) Hashtbl.t
let node_succ:node_succ_t = Hashtbl.create 100
        
let (of_id:Dot_ast.id -> string) =
  function Ident str | Html str | Number str | String str -> str

let (of_node_id:Dot_ast.node_id -> string) = fun id -> of_id (fst id)
let (of_node:Dot_ast.node -> string) = function
  | NodeId node_id -> of_node_id node_id
  | NodeSub _subgraph -> assert false    


let (get_file: Dot_ast.node_id  -> Dot_ast.attr list -> string) =
  fun node_id attrs ->
    let attrs = List.flatten attrs in (* XXX why a list of list ? *)
    try  (
        match List.assoc (Ident "algo") attrs with
          None -> assert false
        | Some id -> of_id id
      ) 
    with Not_found -> failwith ((of_node_id node_id)^" should have an algo attribute")

let (get_init: Dot_ast.attr list -> (string * string) list ) =
  fun attrs ->
    let attrs = List.flatten attrs in (* XXX why a list of list ? *)
    let init_list =
      List.fold_left
        (fun acc (id,idopt) ->
           if id <> Ident "init" then acc else
             match idopt with
             | Some (String id) -> (
                 try
                   let i = String.index id '=' in
                   let l = String.length id in
                   (String.sub id 0 i, String.sub id (i+1) (l-i-1))::acc
                 with
                   Not_found -> acc
               )
             | _ -> acc
        )
        []
        attrs
    in
    init_list
      
let (do_stmt: bool -> node list -> Dot_ast.stmt -> node list) =
  fun directed n stmt ->
    match stmt with
    | Node_stmt (node_id, attrs) ->
      let id = of_node_id node_id in
      let inits = get_init attrs  in
      let node = { id=id ; file = get_file node_id attrs ; init = inits } in
      Hashtbl.replace node_info id node;
      node::n
    | Edge_stmt (node, nodes, _attrs) ->
      let node = of_node node in
      let nodes = List.map of_node nodes in
        (* for egdes written "a -- b -- c -- d", which
           is a shortcut for "
           a -- b
           b -- c
           c -- d
           "
           Graph.Dot.parse_dot_ast returns the pair a,[b,c,d]
           which is weird IMHO.   
           The code below add the missing edges:
        *)
      let add_edge n1 n2 =
        if n1 = n2 then failwith
            (Printf.sprintf
               "Bad topology: %s can not ne a neighbor of itself!" n1);
        let pn1 = try Hashtbl.find node_succ n1 with Not_found -> [] in
        let pn2 = try Hashtbl.find node_succ n2 with Not_found -> [] in
        Hashtbl.replace node_succ n1 (n2::pn1);
        if not directed then Hashtbl.replace node_succ n2 (n1::pn2);
        n2
      in
      ignore (List.fold_left add_edge node nodes);
      n
    | Attr_graph _attrs -> n
    | Attr_node  _attrs -> n 
    | Attr_edge  _attrs ->  n
    | Equal (_id1, _id2) -> assert false
    | Subgraph _subgraph -> assert false


let (read: string -> t) = fun f ->
  let dot_file = Graph.Dot.parse_dot_ast f in
  assert (not dot_file.strict);
  let res = List.fold_left (do_stmt dot_file.digraph) [] dot_file.stmts in
  {
    nodes = List.rev res;
    succ = (fun str -> try Hashtbl.find node_succ str with Not_found -> []);
    of_id = (fun str -> try Hashtbl.find node_info str with Not_found ->
        failwith (str^ " unknown node id")
      )
  }