Find recursive dependencies, output into a dot file

package.ml

#!/usr/bin/env ocaml
#use "topfind"
#require "findlib"
#require "astring"

let requires name =
  try
    let reqs = Findlib.package_property ["native"] name "requires" in
    Astring.String.cuts ~empty:false ~sep:" " reqs
  with Not_found -> []

let version name =
  try
    let v = Findlib.package_property ["native"] name "version" in
    if Astring.String.is_infix ~affix:"distributed with O" v then
      "ocaml"
    else
      v
  with Not_found -> "0"

module SM = Map.Make(String)

let deps start =
  let rec one (s, acc) name =
    if SM.mem name s then
      (s, acc)
    else
      try
        let direct = requires name in
        let v = version name in
        let acc = (name, direct) :: acc in
        let s = SM.add name v s in
        List.fold_left one (s, acc) direct
      with
        _ -> (s, acc)
  in
  List.fold_left one (SM.empty, []) start

let p_edge (n, ds) =
  List.map (fun o -> Printf.sprintf "\"%s\" -> \"%s\"" n o) ds

let ca, cb, cc = ( "#C02942", "#ECD078", "#D95B43" )

let p_node top k v acc =
  let l, c =
    if v = "ocaml" then
      (k, ca)
    else if List.mem k top then
      (k ^ "\n" ^ v, cb)
    else
      (k ^ "\n" ^ v, cc)
  in
  Printf.sprintf "\"%s\" [label=\"%s\" fillcolor=\"%s\" style=filled]" k l c :: acc

let print_deps name pkgs =
  let pkgs = List.flatten (List.map (Astring.String.cuts ~empty:false ~sep:",") pkgs) in
  let map, deps = deps pkgs in
  let nodes = SM.fold (p_node pkgs) map [] in
  let edges = List.flatten (List.map p_edge deps) in
  Printf.printf "digraph \"%s\" {\n  %s;\n\n\n  %s;\n}\n" name
    (String.concat ";\n  " nodes)
    (String.concat ";\n  " edges)

let () = match List.tl (Array.to_list Sys.argv) with
  | [] -> print_endline "no input, no output"
  | [name] -> print_endline "need a graph name and packages"
  | name::pkgs -> print_deps name pkgs

(* call ./package.ml mirage-console functoria.runtime,mirage-console.unix,mirage-types.lwt,mirage-unix,mirage.runtime > mirage-console.dot *)
(* postprocessing: dot -T svg x.dot > x.svg *)