(*

   'let' names nets (scoped vars)
   'fun' names ports (argument vars)



digraph {
  compound=true;
  node [shape=record];
  edge [decorate=true];
  rankdir="LR";

  subgraph G {
    label="let rec fact n = if n = 0 then 1. else float n *. fact (n - 1)";

    cluster=true;
    labeljust="l";
    "1.";
    "if/then/else" [label="{{<1>if|<2>then|<3>else}|<o>}"];
    "1";
    "0";

    minus [label="{{<1>|<2>}|<o>-}"];

  float_mult [label="{{<1>|<2>}|<o>*.}"];
  "float" [label="{<1>|<o>float}"];
  "(=)" [label="{{<1>|<2>}|<o>=}"];
  "fun n" [label="{<o>fun|<1>n}"];
  "factorial" [label="{<1>|<o>factorial}"];
  
  
  "1." -> "if/then/else":2 [label="float"];
  "fun n":1 -> minus:1 [lhead="cluster_minus" label="int"];
  "fun n":1 -> "(=)":2 [label="int"];
  "fun n":1 -> "float":1 [label="int"];
  "if/then/else" -> "->":o [label="float"];
  "1" -> minus:2 [lhead="cluster_minus" label="int"];
  "0" -> "(=)":1 [label="int"];
  minus:o -> "factorial":1 [label="int"];
  float_mult:o -> "if/then/else":3 [label="float"];
  "float":o -> float_mult:1 [label="float"];
  "(=)":o -> "if/then/else":1 [label="bool"];
  "factorial":o -> float_mult:2 [label="float"];
  
  }
}


   
 *)

open Merlin_kernel
open Merlin_analysis
open Merlin_specific
open Merlin_utils
open Ocaml_parsing
open Ocaml_typing

let _ =
  Logs.set_reporter (Logs_fmt.reporter ());
  Logs.set_level (Some Debug)

module F = struct
  include Fmt

  let bar ppf () = string ppf "|"
end

module Log =
  (val Logs.src_log
         (Logs.Src.create "dot_of_tast" ~doc:"dot_of_tast.ml logger")
      : Logs.LOG)

open Graph

module DotAttributes = struct
  include Graphviz.DotAttributes

  (* the dot spec probably added records after ocamlgraph/src/graphviz.ml was written *)
  type edge =
    [ Graphviz.DotAttributes.edge
    | `HeadportRecord of string
    | `TailportRecord of string ]
end

module Gr = struct
  open DotAttributes

  module Vertex = struct
    type t = {
      name : string;
      attr : DotAttributes.vertex list;
      subgraph : DotAttributes.subgraph option;
    }

    let compare a b = String.compare a.name b.name
    let hash { name; _ } = Hashtbl.hash name
    let equal a b = compare a b = 0
    let label a = a.name
    let default = { name = ""; attr = []; subgraph = None }
  end

  module Edge = struct
    type t = { name : string; attr : DotAttributes.edge list }

    let compare a b = String.compare a.name b.name
    let default = { name = ""; attr = [] }
  end

  module G = Imperative.Digraph.ConcreteLabeled (Vertex) (Edge)
  module B = Builder.I (G)
  module V = G.V
  module E = G.E

  type t = G.t * graph list

  let iter_vertex a (b, _) = G.iter_vertex a b
  let iter_edges_e a (b, _) = G.iter_edges_e a b
  let add_edge_e (a, _) b = G.add_edge_e a b
  let vertex_name v = F.str "\"%s\"" (String.escaped (Vertex.label v))
  let graph_attributes (_g, attr) = attr
  let default_vertex_attributes _ = [ `Shape `Record ]
  let vertex_attributes (a : V.t) = a.attr
  let default_edge_attributes _ = [ `Decorate true ]

  let edge_attributes ((_src, { name; attr; _ }, _dst) : E.t) =
    if String.equal name "" then attr else `Label name :: attr

  let get_subgraph (v : G.V.t) :
      Graphviz.DotAttributes.subgraph option =
    v.subgraph

  let create ?(size = 32) attr = (B.G.create ~size (), attr)
end

module Dot = struct
  module X = struct
    include Gr
  end

  open Format

  module EN = struct
    type color = int
    type color_with_transparency = int32

    let color_to_color_with_transparency color =
      Int32.add (Int32.shift_left (Int32.of_int color) 8) 0xFFl

    let fprint_color ppf color = fprintf ppf "\"#%06X\"" color

    let fprint_color_with_transparency ppf color =
      fprintf ppf "\"#%08lX\"" color

    let fprint_string ppf s = fprintf ppf "\"%s\"" s
    (* let s' = String.escaped s in
       if s' = s && s <> ""
       then fprintf ppf "%s" s
       else fprintf ppf "\"%s\"" s'*)

    let fprint_string_user ppf s =
      (*  let s = String.escaped s in*)
      fprintf ppf "\"%s\"" s

    let fprint_htmlstring_user ppf s = fprintf ppf "<%s>" s

    let fprint_square_not_empty printer ppf = function
      | [] -> ()
      | l -> fprintf ppf " [%a]" printer l

    type arrow_style =
      [ `None
      | `Normal
      | `Onormal
      | `Inv
      | `Dot
      | `Odot
      | `Invdot
      | `Invodot ]

    let fprint_arrow_style ppf = function
      | `None -> fprintf ppf "none"
      | `Normal -> fprintf ppf "normal"
      | `Onormal -> fprintf ppf "onormal"
      | `Inv -> fprintf ppf "inv"
      | `Dot -> fprintf ppf "dot"
      | `Odot -> fprintf ppf "odot"
      | `Invdot -> fprintf ppf "invdot"
      | `Invodot -> fprintf ppf "invodot"

    let fprint_dir ppf = function
      | `TopToBottom -> fprintf ppf "TB"
      | `BottomToTop -> fprintf ppf "BT"
      | `LeftToRight -> fprintf ppf "LR"
      | `RightToLeft -> fprintf ppf "RL"

    type symbseq = COMMA | SEMI

    let fprint_symbseq ppf = function
      | COMMA -> pp_print_string ppf ","
      | SEMI -> pp_print_string ppf ";"

    module Attributes = struct
      module CommonAttributes = struct
        include Graphviz.CommonAttributes
        (** Pretty-print. *)

        let fprint_orientation ppf = function
          | `Portrait -> fprintf ppf "portrait"
          | `Landscape -> fprintf ppf "landscape"

        let fprint_graph ppf = function
          | `Center b -> fprintf ppf "center=%i" (if b then 1 else 0)
          | `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a
          | `Fontname s -> fprintf ppf "fontname=%a" fprint_string s
          | `Fontsize i -> fprintf ppf "fontsize=%i" i
          | `Label s -> fprintf ppf "label=%a" fprint_string_user s
          | `HtmlLabel s ->
              fprintf ppf "label=%a" fprint_htmlstring_user s
          | `Orientation a ->
              fprintf ppf "orientation=%a" fprint_orientation a
          | `Page (x, y) -> fprintf ppf "page=\"%f,%f\"" x y
          | `Pagedir a -> fprintf ppf "pagedir=%a" fprint_dir a
          | `Size (x, y) -> fprintf ppf "size=\"%f,%f\"" x y
          | `OrderingOut -> fprintf ppf "ordering=out"

        let fprint_shape ppf = function
          | `Ellipse -> fprintf ppf "ellipse"
          | `Box -> fprintf ppf "box"
          | `Circle -> fprintf ppf "circle"
          | `Doublecircle -> fprintf ppf "doublecircle"
          | `Diamond -> fprintf ppf "diamond"
          | `Plaintext -> fprintf ppf "plaintext"
          | `Record -> fprintf ppf "record"
          | `Egg -> fprintf ppf "egg"
          | `House -> fprintf ppf "house"
          | `Invhouse -> fprintf ppf "invhouse"
          | `Trapezium -> fprintf ppf "trapezium"
          | `Invtrapezium -> fprintf ppf "invtrapezium"
          | `Triangle -> fprintf ppf "triangle"
          | `Invtriangle -> fprintf ppf "invtriangle"
          | `Oval -> fprintf ppf "oval"
          | `Assembly -> fprintf ppf "assembly"
          | `Box3d -> fprintf ppf "box3d"
          | `Cds -> fprintf ppf "cds"
          | `Component -> fprintf ppf "component"
          | `Doubleoctagon -> fprintf ppf "doubleoctagon"
          | `Fivepoverhang -> fprintf ppf "fivepoverhang"
          | `Folder -> fprintf ppf "folder"
          | `Insulator -> fprintf ppf "insulator"
          | `Larrow -> fprintf ppf "larrow"
          | `Lpromoter -> fprintf ppf "lpromoter"
          | `Mcircle -> fprintf ppf "mcircle"
          | `Mdiamond -> fprintf ppf "mdiamond"
          | `Msquare -> fprintf ppf " msquare"
          | `Note -> fprintf ppf "note"
          | `Noverhang -> fprintf ppf "noverhang"
          | `Parallelogram -> fprintf ppf "parallelogram"
          | `Primersite -> fprintf ppf "primersite"
          | `Promoter -> fprintf ppf "promoter"
          | `Proteasesite -> fprintf ppf "proteasesite"
          | `Proteinstab -> fprintf ppf "proteinstab"
          | `Rarrow -> fprintf ppf "rarrow"
          | `Restrictionsite -> fprintf ppf "restrictionsite"
          | `Ribosite -> fprintf ppf "ribosite"
          | `Rnastab -> fprintf ppf "rnastab"
          | `Rpromoter -> fprintf ppf "rpromoter"
          | `Signature -> fprintf ppf "signature"
          | `Star -> fprintf ppf "star"
          | `Tab -> fprintf ppf "tab"
          | `Terminator -> fprintf ppf "terminator"
          | `Threepoverhang -> fprintf ppf "threepoverhang"
          | `Tripleoctagon -> fprintf ppf "tripleoctagon"
          | `Underline -> fprintf ppf "underline"
          | `Utr -> fprintf ppf "utr"
          | `Polygon (i, f) ->
              fprintf ppf "polygon, sides=%i, skew=%f" i f

        let rec fprint_string_list ppf = function
          | [] -> ()
          | [ hd ] -> fprintf ppf "%s" hd
          | hd :: tl -> fprintf ppf "%s,%a" hd fprint_string_list tl

        let node_style_str = function
          | `Rounded -> "rounded"
          | `Filled -> "filled"
          | `Solid -> "solid"
          | `Dashed -> "dashed"
          | `Dotted -> "dotted"
          | `Bold -> "bold"
          | `Invis -> "invis"

        let fprint_style_list sep ppf a =
          fprintf ppf "style=\"%a\"%a@ " fprint_string_list
            (List.map node_style_str a)
            fprint_symbseq sep

        let fprint_vertex ppf = function
          | `Color a -> fprintf ppf "color=%a" fprint_color a
          | `ColorWithTransparency a ->
              fprintf ppf "color=%a" fprint_color_with_transparency a
          | `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a
          | `Fontname s -> fprintf ppf "fontname=%a" fprint_string s
          | `Fontsize i -> fprintf ppf "fontsize=%i" i
          | `Height f -> fprintf ppf "height=%f" f
          | `Label s -> fprintf ppf "label=%a" fprint_string_user s
          | `HtmlLabel s ->
              fprintf ppf "label=%a" fprint_htmlstring_user s
          | `Orientation f -> fprintf ppf "orientation=%f" f
          | `Penwidth f -> fprintf ppf "penwidth=%f" f
          | `Peripheries i -> fprintf ppf "peripheries=%i" i
          | `Regular b -> fprintf ppf "regular=%b" b
          | `Shape a -> fprintf ppf "shape=%a" fprint_shape a
          | `Style _ -> assert false
          | `Width f -> fprintf ppf "width=%f" f

        let fprint_arrow_direction ppf = function
          | `Forward -> fprintf ppf "forward"
          | `Back -> fprintf ppf "back"
          | `Both -> fprintf ppf "both"
          | `None -> fprintf ppf "none"

        let fprint_edge ppf = function
          | `Color a -> fprintf ppf "color=%a" fprint_color a
          | `ColorWithTransparency a ->
              fprintf ppf "color=%a" fprint_color_with_transparency a
          | `Decorate b -> fprintf ppf "decorate=%b" b
          | `Dir a -> fprintf ppf "dir=%a" fprint_arrow_direction a
          | `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a
          | `Fontname s -> fprintf ppf "fontname=%a" fprint_string s
          | `Fontsize i -> fprintf ppf "fontsize=%i" i
          | `Label s -> fprintf ppf "label=%a" fprint_string_user s
          | `HtmlLabel s ->
              fprintf ppf "label=%a" fprint_htmlstring_user s
          | `Labelfontcolor a ->
              fprintf ppf "labelfontcolor=%a" fprint_color a
          | `Labelfontname s -> fprintf ppf "labelfontname=\"%s\"" s
          (* (String.escaped s) *)
          | `Labelfontsize i -> fprintf ppf "labelfontsize=%i" i
          | `Penwidth f -> fprintf ppf "penwidth=%f" f
          | `Style _ -> assert false

        let rec filter_style al sl l =
          match l with
          | [] -> (al, sl)
          | `Style s :: l -> filter_style al (s :: sl) l
          | a :: l -> filter_style (a :: al) sl l

        (** [fprint_graph_attribute printer ppf list] pretty prints a list of
      attributes on the formatter [ppf], using the printer [printer] for
      each attribute.  The list appears between brackets and attributes
      are speparated by ",".  If the list is empty, nothing is printed. *)
        let fprint_attributes fprint_style_list fprint_attribute sep
            ppf list =
          if list <> [] then (
            let list, styles = filter_style [] [] list in
            let rec fprint_attributes_rec ppf = function
              | [] -> ()
              | hd :: tl ->
                  fprintf ppf "%a%a@ " fprint_attribute hd
                    fprint_symbseq sep;
                  fprint_attributes_rec ppf tl
            in
            fprintf ppf "@[<hov>%a" fprint_attributes_rec list;
            if styles <> [] then fprint_style_list sep ppf styles;
            fprintf ppf "@]")
      end

      include DotAttributes
      (** {4 Pretty-print of attributes} *)

      let rec fprint_string_list ppf = function
        | [] -> ()
        | [ hd ] -> fprintf ppf "%s" hd
        | hd :: tl -> fprintf ppf "%s,%a" hd fprint_string_list tl

      let fprint_ratio ppf = function
        | `Float f -> fprintf ppf "%f" f
        | `Fill -> fprintf ppf "fill"
        | `Compress -> fprintf ppf "compress"
        | `Auto -> fprintf ppf "auto"

      let fprint_graph ppf = function
        | #CommonAttributes.graph as att ->
            CommonAttributes.fprint_graph ppf att
        | `Bgcolor a -> fprintf ppf "bgcolor=%a" fprint_color a
        | `BgcolorWithTransparency a ->
            fprintf ppf "bgcolor=%a" fprint_color_with_transparency a
        | `Comment s -> fprintf ppf "comment=%a" fprint_string s
        | `Concentrate b -> fprintf ppf "concentrate=%b" b
        | `Fontpath s -> fprintf ppf "fontpath=%a" fprint_string s
        | `Layers s -> fprintf ppf "layers=%a" fprint_string_list s
        | `Margin f -> fprintf ppf "margin=%f" f
        | `Mclimit f -> fprintf ppf "mclimit=%f" f
        | `Nodesep f -> fprintf ppf "nodesep=%f" f
        | `Nslimit i -> fprintf ppf "nslimit=%i" i
        | `Nslimit1 i -> fprintf ppf "nslimit1=%i" i
        | `Ranksep f -> fprintf ppf "ranksep=%f" f
        | `Quantum f -> fprintf ppf "quantum=%f" f
        | `Rankdir a -> fprintf ppf "rankdir=%a" fprint_dir a
        | `Ratio a -> fprintf ppf "ratio=%a" fprint_ratio a
        | `Samplepoints i -> fprintf ppf "samplepoints=%i" i
        | `Url s -> fprintf ppf "URL=\"%s\"" s (*(String.escaped s)*)

      let fprint_vertex ppf = function
        | #CommonAttributes.vertex as att ->
            CommonAttributes.fprint_vertex ppf att
        | `Comment s -> fprintf ppf "comment=%a" fprint_string s
        | `Distortion f -> fprintf ppf "distortion=%f" f
        | `Fillcolor a -> fprintf ppf "fillcolor=%a" fprint_color a
        | `FillcolorWithTransparency a ->
            fprintf ppf "fillcolor=%a" fprint_color_with_transparency
              a
        | `Fixedsize b -> fprintf ppf "fixedsize=%b" b
        | `Layer s -> fprintf ppf "layer=%a" fprint_string s
        | `Url s -> fprintf ppf "URL=\"%s\"" s (*(String.escaped s)*)
        | `Z f -> fprintf ppf "z=%f" f

      let fprint_port ppf = function
        | `N -> fprintf ppf "n"
        | `NE -> fprintf ppf "ne"
        | `E -> fprintf ppf "e"
        | `SE -> fprintf ppf "se"
        | `S -> fprintf ppf "s"
        | `SW -> fprintf ppf "sw"
        | `W -> fprintf ppf "w"
        | `NW -> fprintf ppf "nw"

      let fprint_edge ppf = function
        | #CommonAttributes.edge as att ->
            CommonAttributes.fprint_edge ppf att
        | `Arrowhead a ->
            fprintf ppf "arrowhead=%a" fprint_arrow_style a
        | `Arrowsize f -> fprintf ppf "arrowsize=%f" f
        | `Arrowtail a ->
            fprintf ppf "arrowtail=%a" fprint_arrow_style a
        | `Comment s -> fprintf ppf "comment=%a" fprint_string s
        | `Constraint b -> fprintf ppf "constraint=%b" b
        | `Headlabel s -> fprintf ppf "headlabel=%a" fprint_string s
        | `Headport a -> fprintf ppf "headport=%a" fprint_port a
        | `HeadportRecord a ->
            fprintf ppf "headport=%a" fprint_string a
        | `Headurl s -> fprintf ppf "headURL=%a" fprint_string s
        | `Labelangle f -> fprintf ppf "labelangle=%f" f
        | `Labeldistance f -> fprintf ppf "labeldistance=%f" f
        | `Labelfloat b -> fprintf ppf "labelfloat=%b" b
        | `Layer s -> fprintf ppf "layer=%a" fprint_string s
        | `Minlen i -> fprintf ppf "minlen=%i" i
        | `Samehead s -> fprintf ppf "samehead=%a" fprint_string s
        | `Sametail s -> fprintf ppf "sametail=%a" fprint_string s
        | `Taillabel s -> fprintf ppf "taillabel=%a" fprint_string s
        | `Tailport a -> fprintf ppf "tailport=%a" fprint_port a
        | `TailportRecord a ->
            fprintf ppf "tailport=%a" fprint_string a
        | `Tailurl s -> fprintf ppf "tailURL=%a" fprint_string s
        | `Weight i -> fprintf ppf "weight=%i" i

      let fprint_vertex_list =
        CommonAttributes.fprint_attributes
          CommonAttributes.fprint_style_list fprint_vertex

      let fprint_edge_list =
        CommonAttributes.fprint_attributes
          CommonAttributes.fprint_style_list fprint_edge
    end

    let name = "dot"
    let opening = "digraph"
    let edge_arrow = "->"
  end

  open Format
  (** {3 Common attributes} *)

  type color = int
  type color_with_transparency = int32

  let color_to_color_with_transparency color =
    Int32.add (Int32.shift_left (Int32.of_int color) 8) 0xFFl

  let fprint_color ppf color = fprintf ppf "\"#%06X\"" color

  let fprint_color_with_transparency ppf color =
    fprintf ppf "\"#%08lX\"" color

  let fprint_string ppf s = fprintf ppf "\"%s\"" s
  (* let s' = String.escaped s in
     if s' = s && s <> ""
     then fprintf ppf "%s" s
     else fprintf ppf "\"%s\"" s'*)

  let fprint_string_user ppf s =
    (*  let s = String.escaped s in*)
    fprintf ppf "\"%s\"" s

  let fprint_htmlstring_user ppf s = fprintf ppf "<%s>" s

  let fprint_square_not_empty printer ppf = function
    | [] -> ()
    | l -> fprintf ppf " [%a]" printer l

  type arrow_style =
    [ `None
    | `Normal
    | `Onormal
    | `Inv
    | `Dot
    | `Odot
    | `Invdot
    | `Invodot ]

  let fprint_arrow_style ppf = function
    | `None -> fprintf ppf "none"
    | `Normal -> fprintf ppf "normal"
    | `Onormal -> fprintf ppf "onormal"
    | `Inv -> fprintf ppf "inv"
    | `Dot -> fprintf ppf "dot"
    | `Odot -> fprintf ppf "odot"
    | `Invdot -> fprintf ppf "invdot"
    | `Invodot -> fprintf ppf "invodot"

  let fprint_dir ppf = function
    | `TopToBottom -> fprintf ppf "TB"
    | `BottomToTop -> fprintf ppf "BT"
    | `LeftToRight -> fprintf ppf "LR"
    | `RightToLeft -> fprintf ppf "RL"

  type symbseq = COMMA | SEMI

  let fprint_symbseq ppf = function
    | COMMA -> pp_print_string ppf ","
    | SEMI -> pp_print_string ppf ";"

  (* had to copy out of ocamlgraph/src/graphviz.ml because people don't make shit extensible *)
  let command = ref EN.name
  let set_command cmd = command := cmd

  exception Error of string

  let handle_error f arg =
    try f arg
    with Error msg ->
      Printf.eprintf "%s: %s failure\n   %s\n" Sys.argv.(0) EN.name
        msg;
      flush stderr;
      exit 2

  (** [fprint_graph_attributes ppf list] pretty prints a list of
      graph attributes on the formatter [ppf].  Attributes are separated
      by a ";". *)
  let fprint_graph_attributes ppf list =
    List.iter
      (function
        | att -> fprintf ppf "%a;@ " EN.Attributes.fprint_graph att)
      list

  (** [fprint_graph ppf graph] pretty prints the graph [graph] in
      the CGL language on the formatter [ppf]. *)
  let fprint_graph ppf graph =
    let module SG = Map.Make (String) in
    let subgraphs = ref SG.empty in

    (* Printing nodes. *)
    let print_nodes ppf =
      let default_node_attributes =
        X.default_vertex_attributes graph
      in
      if default_node_attributes <> [] then
        fprintf ppf "node%a;@ "
          (fprint_square_not_empty
             (EN.Attributes.fprint_vertex_list COMMA))
          default_node_attributes;

      X.iter_vertex
        (function
          | node ->
              (match X.get_subgraph node with
              | None -> ()
              | Some sg ->
                  let sg, nodes =
                    if SG.mem sg.EN.Attributes.sg_name !subgraphs then
                      SG.find sg.EN.Attributes.sg_name !subgraphs
                    else (sg, [])
                  in
                  subgraphs :=
                    SG.add sg.EN.Attributes.sg_name
                      (sg, node :: nodes)
                      !subgraphs);
              fprintf ppf "%s%a;@ " (X.vertex_name node)
                (fprint_square_not_empty
                   (EN.Attributes.fprint_vertex_list COMMA))
                (X.vertex_attributes node))
        graph
    in

    (* Printing subgraphs *)
    let rec print_nested_subgraphs ppf = function
      | [] -> () (* no more work to do, so terminate *)
      | name :: worklist ->
          let sg, nodes = SG.find name !subgraphs in
          let children =
            SG.filter
              (fun _ (sg, _) ->
                sg.EN.Attributes.sg_parent = Some name)
              !subgraphs
          in
          fprintf ppf "@[<v 2>subgraph cluster_%s { %a%t@ %t };@]@\n"
            name
            (EN.Attributes.fprint_vertex_list SEMI)
            sg.EN.Attributes.sg_attributes
            (fun ppf ->
              List.iter
                (fun n -> fprintf ppf "%s;" (X.vertex_name n))
                nodes)
            (fun ppf ->
              print_nested_subgraphs ppf
                (List.map fst (SG.bindings children)));

          print_nested_subgraphs ppf worklist
    in

    let print_subgraphs ppf =
      let root_worklist =
        SG.filter
          (fun _ (sg, _) -> sg.EN.Attributes.sg_parent = None)
          !subgraphs
      in
      print_nested_subgraphs ppf
        (List.map fst (SG.bindings root_worklist))
    in

    (* Printing edges *)
    let print_edges ppf =
      let default_edge_attributes = X.default_edge_attributes graph in
      if default_edge_attributes <> [] then
        fprintf ppf "edge%a;@ "
          (fprint_square_not_empty
             (EN.Attributes.fprint_edge_list COMMA))
          default_edge_attributes;

      X.iter_edges_e
        (function
          | edge ->
              fprintf ppf "%s %s %s%a;@ "
                (X.vertex_name (X.E.src edge))
                EN.edge_arrow
                (X.vertex_name (X.E.dst edge))
                (fprint_square_not_empty
                   (EN.Attributes.fprint_edge_list COMMA))
                (X.edge_attributes edge))
        graph
    in

    fprintf ppf "@[<v>%s G {@ @[<v 2>  %a" EN.opening
      fprint_graph_attributes
      (X.graph_attributes graph);
    fprintf ppf "%t@ " print_nodes;
    fprintf ppf "%t@ " print_subgraphs;
    fprintf ppf "%t@ " print_edges;
    fprintf ppf "@]}@;@]"

  (** [output_graph oc graph] pretty prints the graph [graph] in the dot
      language on the channel [oc]. *)
  let output_graph oc graph =
    let ppf = formatter_of_out_channel oc in
    fprint_graph ppf graph;
    pp_print_flush ppf ()
end

module Pmapper = struct
  type t = Ast_mapper.mapper

  let default = Ast_mapper.default_mapper

  let remove_attributes : t =
    { default with attributes = (fun _m _alist -> []) }
end

(* Stolen from ocaml/typing/printtyped.ml cause it's not exposed!! *)
module Pp = struct
  open Asttypes
  open Format
  open Lexing
  open Location
  open Typedtree
  module Path = Ocaml_typing.Path

  let rec fmt_longident_aux f x =
    match x with
    | Longident.Lident s -> fprintf f "%s" s
    | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s
    | Longident.Lapply (y, z) ->
        fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z

  let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt
  let fmt_ident = Ident.print

  let fmt_modname f = function
    | None -> fprintf f "_"
    | Some id -> Ident.print f id

  let rec fmt_path f x =
    match x with
    | Path.Pident s -> fprintf f "%a" fmt_ident s
    | Path.Pdot (y, s) -> fprintf f "%a.%s" fmt_path y s
    | Path.Papply (y, z) -> fprintf f "%a(%a)" fmt_path y fmt_path z

  let fmt_partial f = function
    | Partial -> F.pf f "partial"
    | Total -> F.pf f "total"

  let fmt_position f l =
    if l.pos_lnum = -1 then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
    else
      fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
        (l.pos_cnum - l.pos_bol)

  let fmt_location f loc =
    fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position
      loc.loc_end;
    if loc.loc_ghost then fprintf f " ghost"
end

let str_of_exp (exp : Typedtree.expression) =
  Fmt.str "%a" Pprintast.expression
    Pmapper.(
      remove_attributes.expr remove_attributes
        (Untypeast.untype_expression exp))

open Typedtree

let str_of_pat (pat : value general_pattern) =
  Fmt.str "%a" Pprintast.pattern
    Pmapper.(
      remove_attributes.pat remove_attributes
        (Untypeast.untype_pattern pat))

let str_of_ident = Ident.name
let unique_str_of_ident = Ident.unique_name

let unique_str_of_ident_pat x =
  match x.pat_desc with
  | Tpat_var (s, _) -> F.str "%a" Pp.fmt_ident s
  | _ -> str_of_pat x

let pp_value_binding_list ppf (vbl : Typedtree.value_binding list) =
  Fmt.pf ppf "%a"
    (Fmt.parens
       (Fmt.list (fun ppf (ident, _loc, _ty) -> Ident.print ppf ident)))
    (Typedtree.let_bound_idents_full vbl)

let unique_node_count = ref 0

let vertex_of_exp (exp : Typedtree.expression) : Gr.Vertex.t =
  (* primary isn't well defined here, it's whatever i choosen for src nodes atm *)
  match exp.exp_desc with
  | Texp_ident (path, _longident, _value_desc) ->
      {
        name = F.str "%a" Pp.fmt_path path;
        attr = [ `Label (F.str "{{<in>}|<out>%s}" (str_of_exp exp)) ];
        subgraph = None;
      }
  | Texp_construct _ ->
      {
        Gr.Vertex.default with
        name = F.str "_Texp_construct/%d" !unique_node_count;
        attr = [ `Label (F.str "{<out>%s}" (str_of_exp exp)) ];
      }
  | Texp_constant _ ->
      {
        Gr.Vertex.default with
        name = F.str "_Texp_constant/%d" !unique_node_count;
        attr = [ `Label (F.str "{<0>|<out>%s}" (str_of_exp exp)) ];
      }
  | Texp_variant _ -> { Gr.Vertex.default with name = str_of_exp exp }
  | Texp_apply (exp, args) ->
      let cnt = ref 0 in
      let label =
        F.str "{{%a}|<out>%s}"
          (F.list ~sep:F.bar (fun ppf -> function
             | Asttypes.Nolabel, _exp ->
                 F.pf ppf "<%d>" !cnt;
                 cnt := !cnt + 1
             | Asttypes.(Labelled s | Optional s), _exp ->
                 F.pf ppf "<%s>" s))
          args (str_of_exp exp)
      in
      {
        Gr.Vertex.default with
        name = str_of_exp exp;
        attr = [ `Label label ];
      }
  | Texp_let (_, vbl, _) ->
      {
        Gr.Vertex.default with
        name = Fmt.str "let %a" pp_value_binding_list vbl;
      }
  | Texp_ifthenelse (_, _, _) -> Gr.Vertex.default
  | _ ->
      {
        Gr.Vertex.default with
        name = Fmt.str "???? (%s)" (str_of_exp exp);
      }

let labeled_vertex name label =
  { Gr.Vertex.default with name; attr = [ `Label label ] }

let dst_stk : (Gr.V.t * int) Stack.t = Stack.create ()

let expr_iterator g (iter : Tast_iterator.iterator)
    (exp : Typedtree.expression) =
  let extra = function
    | Typedtree.Texp_constraint cty -> iter.typ iter cty
    | Texp_coerce (cty1, cty2) ->
        Option.iter (iter.typ iter) cty1;
        iter.typ iter cty2
    | Texp_newtype _ -> ()
    | Texp_newtype' _ -> ()
    | Texp_poly cto -> Option.iter (iter.typ iter) cto
  in
  List.iter (fun (e, _, _) -> extra e) exp.exp_extra;
  iter.env iter exp.exp_env;

  let srcport = "out" in
  incr unique_node_count;
  let src =
    let open Typedtree in
    match exp.exp_desc with
    | Texp_apply (_exp, list) ->
        let src = vertex_of_exp exp in
        (* Tast_iterator.default_iterator.expr iter exp *)
        (* skip _exp *)
        List.fold_left
          (fun i (arg_label, expopt) ->
            Option.iter
              (fun ee ->
                Stack.push (src, i) dst_stk;
                iter.expr iter ee;
                Stack.pop dst_stk |> ignore)
              expopt;
            match arg_label with Asttypes.Nolabel -> i + 1 | _ -> i)
          0 list
        |> ignore;
        src
    | Texp_ifthenelse (e0, e1, e2) ->
        let src =
          match e2 with
          | Some _ ->
              {
                Gr.Vertex.default with
                (* TODO make unique (with loc?) *)
                name = "if/then/else";
                attr = [ `Label "{{<0>if|<1>then|<2>else}|<out>}" ];
              }
          | None ->
              {
                Gr.Vertex.default with
                name = "if/then";
                attr = [ `Label "{{<1>if|<2>then}|<out>}" ];
              }
        in
        Stack.push (src, 0) dst_stk;
        iter.expr iter e0;
        Stack.pop dst_stk |> ignore;
        Stack.push (src, 1) dst_stk;
        iter.expr iter e1;
        Stack.pop dst_stk |> ignore;
        Option.iter
          (fun e' ->
            Stack.push (src, 2) dst_stk;
            iter.expr iter e';
            Stack.pop dst_stk |> ignore)
          e2;
        src
    | Texp_function { arg_label = _; param; cases; partial = _ } ->
        let src =
          labeled_vertex
            (unique_str_of_ident param)
            (F.str "{{<in>function %s}|{%s}}"
               (unique_str_of_ident param)
               (fst
                  (List.fold_left
                     (fun (s, i) { c_lhs; c_guard; _ } ->
                       ( F.str "%s|<%d>%s%s" s i (str_of_pat c_lhs)
                           (Option.fold ~none:""
                              ~some:(fun _ -> " with TODO c_guard")
                              c_guard),
                         i + 1 ))
                     ("", 0) cases))
               (* -> *))
        in
        List.iteri
          (fun i { c_lhs; c_rhs; _ } ->
            Stack.push (src, i) dst_stk;
            iter.expr iter c_rhs;
            Gr.add_edge_e g
              ( src,
                Gr.Edge.
                  {
                    name = "";
                    attr =
                      [
                        `HeadportRecord "in";
                        `TailportRecord (F.str "%d" i);
                      ];
                  },
                labeled_vertex
                  (unique_str_of_ident_pat c_lhs)
                  "{<in>|LOL}" );
            Stack.pop_opt dst_stk |> ignore)
          cases;
        src
    | _ ->
        let src = vertex_of_exp exp in
        Stack.push (src, 0) dst_stk;
        Tast_iterator.default_iterator.expr iter exp;
        Stack.pop_opt dst_stk |> ignore;
        src
  in
  match Stack.top_opt dst_stk with
  | Some (dst, dstport) ->
      Log.debug (fun m ->
          m "G.add_edge %s:%s %s:%s" (Gr.Vertex.label src) srcport
            (Gr.Vertex.label dst) (F.str "%d" dstport));
      Gr.add_edge_e g
        ( src,
          Gr.Edge.
            {
              name = "";
              attr =
                [
                  `HeadportRecord (F.str "%d" dstport);
                  `TailportRecord srcport;
                ];
            },
          dst )
  | None -> ()

let graph_of_impl (s : Typedtree.structure) : Gr.t =
  let g = Gr.create [ `Rankdir `LeftToRight ] in
  let iterator =
    { Tast_iterator.default_iterator with expr = expr_iterator g }
  in
  iterator.structure iterator s;
  g

(* Stolen from ocaml/typing/printtyped.ml cause it's not exposed!! *)
module P = struct
  open Asttypes
  open Format
  open Lexing
  open Location
  open Typedtree
  module Path = Ocaml_typing.Path

  let rec fmt_longident_aux f x =
    match x with
    | Longident.Lident s -> fprintf f "%s" s
    | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s
    | Longident.Lapply (y, z) ->
        fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z

  let fmt_longident f x = fprintf f "%a" fmt_longident_aux x.txt
  let fmt_ident = Ident.print

  let fmt_modname f = function
    | None -> fprintf f "_"
    | Some id -> Ident.print f id

  let rec fmt_path f x =
    match x with
    | Path.Pident s -> fprintf f "%a" fmt_ident s
    | Path.Pdot (y, s) -> fprintf f "%a.%s" fmt_path y s
    | Path.Papply (y, z) -> fprintf f "%a(%a)" fmt_path y fmt_path z

  let fmt_partial f = function
    | Partial -> F.pf f "partial"
    | Total -> F.pf f "total"

  let fmt_position f l =
    if l.pos_lnum = -1 then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
    else
      fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
        (l.pos_cnum - l.pos_bol)

  let fmt_location f loc =
    fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position
      loc.loc_end;
    if loc.loc_ghost then fprintf f " ghost"

  let fmt_constant f x =
    match x with
    | Asttypes.Const_int i -> fprintf f "%d" i
    | Const_char c -> fprintf f "%02x" (Char.code c)
    | Const_string (s, strloc, None) ->
        fprintf f "(%S,%a,None)" s fmt_location strloc
    | Const_string (s, strloc, Some delim) ->
        fprintf f "(%S,%a,Some %S)" s fmt_location strloc delim
    | Const_float s -> fprintf f "%s" s
    | Const_int32 i -> fprintf f "%ld" i
    | Const_int64 i -> fprintf f "%Ld" i
    | Const_nativeint i -> fprintf f "%nd" i

  let string_of_node = function
    | Browse_raw.Dummy -> "Dummy"
    | Pattern _ -> "Pattern"
    | Expression _ -> "Expression"
    | Case _ -> "case"
    | Class_expr _ -> "class_expr"
    | Class_structure _ -> "class_structure"
    | Class_field _ -> "class_field"
    | Class_field_kind _ -> "class_field_kind"
    | Module_expr _ -> "module_expr"
    | Module_type_constraint _ -> "module_type_constraint"
    | Structure _ -> "structure"
    | Structure_item _ -> "structure_item"
    | Module_binding _ -> "module_binding"
    | Value_binding _ -> "value_binding"
    | Module_type _ -> "module_type"
    | Signature _ -> "signature"
    | Signature_item _ -> "signature_item"
    | Module_declaration _ -> "module_declaration"
    | Module_type_declaration _ -> "module_type_declaration"
    | With_constraint _ -> "with_constraint"
    | Core_type _ -> "core_type"
    | Package_type _ -> "package_type"
    | Row_field _ -> "row_field"
    | Value_description _ -> "value_description"
    | Type_declaration _ -> "type_declaration"
    | Type_kind _ -> "type_kind"
    | Type_extension _ -> "type_extension"
    | Extension_constructor _ -> "extension_constructor"
    | Label_declaration _ -> "label_declaration"
    | Constructor_declaration _ -> "constructor_declaration"
    | Class_type _ -> "class_type"
    | Class_signature _ -> "class_signature"
    | Class_type_field _ -> "class_type_field"
    | Class_declaration _ -> "class_declaration"
    | Class_description _ -> "class_description"
    | Class_type_declaration _ -> "class_type_declaration"
    | Method_call _ -> "method_call"
    | Record_field _ -> "record_field"
    | Module_binding_name _ -> "module_binding_name"
    | Module_declaration_name _ -> "module_declaration_name"
    | Module_type_declaration_name _ -> "module_type_declaration_name"
    | Open_description _ -> "open_description"
    | Open_declaration _ -> "open_declaration"
    | Include_description _ -> "include_description"
    | Include_declaration _ -> "include_declaration"

  let string_of_texp = function
    | Texp_ident _ -> "Texp_ident"
    | Texp_constant _ -> "Texp_constant"
    | Texp_apply _ -> "Texp_apply"
    | Texp_instvar _ -> "Texp_instvar"
    | Texp_let _ -> "Texp_let"
    | Texp_function _ -> "Texp_function"
    | Texp_match _ -> "Texp_match"
    | Texp_try _ -> "Texp_try"
    | Texp_tuple _ -> "Texp_tuple"
    | Texp_construct _ -> "Texp_construct"
    | Texp_variant _ -> "Texp_variant"
    | Texp_record _ -> "Texp_record"
    | Texp_field _ -> "Texp_field"
    | Texp_setfield _ -> "Texp_setfield"
    | Texp_array _ -> "Texp_array"
    | Texp_ifthenelse _ -> "Texp_ifthenelse"
    | Texp_sequence _ -> "Texp_sequence"
    | Texp_while _ -> "Texp_while"
    | Texp_for _ -> "Texp_for"
    | Texp_send _ -> "Texp_send"
    | Texp_new _ -> "Texp_new"
    | Texp_setinstvar _ -> "Texp_setinstvar"
    | Texp_override _ -> "Texp_override"
    | Texp_letmodule _ -> "Texp_letmodule"
    | Texp_letexception _ -> "Texp_letexception"
    | Texp_assert _ -> "Texp_assert"
    | Texp_lazy _ -> "Texp_lazy"
    | Texp_object _ -> "Texp_object"
    | Texp_pack _ -> "Texp_pack"
    | Texp_letop _ -> "Texp_letop"
    | Texp_unreachable -> "Texp_unreachable"
    | Texp_extension_constructor _ -> "Texp_extension_constructor"
    | Texp_open _ -> "Texp_open"
    | Texp_hole -> "Texp_hole"

  let str_of_exp (exp : Typedtree.expression) =
    Fmt.str "%a" Pprintast.expression
      Pmapper.(
        remove_attributes.expr remove_attributes
          (Untypeast.untype_expression exp))

  let str_of_pat (pat : 'a general_pattern) =
    Fmt.str "%a" Pprintast.pattern
      Pmapper.(
        remove_attributes.pat remove_attributes
          (Untypeast.untype_pattern pat))
end

let add_edge g ?(srcport = "tl") ?(dstport = "hd") ?(edgename = "")
    src dst =
  Log.debug (fun m ->
      m "G.add_edge %s:%s %s:%s %s" (Gr.Vertex.label src) srcport
        (Gr.Vertex.label dst) dstport edgename);
  Gr.add_edge_e g
    ( src,
      {
        Gr.Edge.name = edgename;
        attr = [ `HeadportRecord dstport; `TailportRecord srcport ];
      },
      dst )

let make_vertex ?(attr = []) ?(label : string option) ?subgraph name =
  Log.debug (fun m ->
      m "G.make_vertex %s [`Label %s]" name
        (Option.value label ~default:""));
  let attr =
    match label with Some s -> `Label s :: attr | None -> attr
  in
  Gr.Vertex.{ name; attr; subgraph }

let ident_counter = ref 0

let rec add_expression g ~dst ~dstport ~edgename { exp_desc; _ } =
  let unique_ident = F.str "/%d" !ident_counter in
  ident_counter := !ident_counter + 1;
  match exp_desc with
  | Texp_ident (p, _, _) ->
      add_edge g
        (make_vertex
           ~label:
             (F.str "{%s (ident)|<tl>}" (Printtyp.string_of_path p))
           (Ident.unique_name (Ocaml_typing.Path.head p)))
        ~dstport dst
  | Texp_constant c ->
      add_edge g
        (make_vertex
           ~label:(F.str "{%a (constant)|<tl>}" P.fmt_constant c)
           unique_ident)
        ~dstport dst
  | Texp_apply (exp0, args) ->
      let rec srcportlist =
        String.concat "|" (List.mapi (fun i _ -> F.str "<%d>" i) args)
      in
      let src =
        make_vertex
          ~label:
            (F.str "{{%s}|%s (apply)|<tl>}" srcportlist
               (P.str_of_exp exp0))
          unique_ident
      in
      add_edge g src dst ~dstport ~edgename;
      List.iteri
        (fun i (arg_label, exp1) ->
          match exp1 with
          | Some e' ->
              add_expression g ~dst:src ~dstport:(Fmt.str "%d" i)
                ~edgename:(Printtyp.string_of_label arg_label)
                e'
          | None -> ())
        args
  | Texp_sequence (exp0, exp1) ->
      let src =
        make_vertex
          ~label:(F.str "{{<0>|<1>}|(sequence)|<tl>}")
          unique_ident
      in
      add_edge g src dst ~dstport ~edgename;
      add_expression g ~dst:src ~dstport:"0" ~edgename:"0" exp0;
      add_expression g ~dst:src ~dstport:"1" ~edgename:"1" exp1
  | Texp_ifthenelse (exp0, exp1, exp2) ->
      let src =
        make_vertex
          ~label:
            (F.str "{{<if>if|<then>then%s}|<tl>}"
               (Option.fold ~none:""
                  ~some:(fun _ -> "|<else>else")
                  exp2))
          unique_ident
      in
      add_edge g src dst ~dstport ~edgename;
      add_expression g ~dst:src ~dstport:"if" ~edgename:"if" exp0;
      add_expression g ~dst:src ~dstport:"then" ~edgename:"then" exp1;
      Option.iter
        (add_expression g ~dst:src ~dstport:"else" ~edgename:"else")
        exp2
  | Texp_let (_rec_flag, _value_binding_list, exp) ->
      let src =
        make_vertex ~label:(F.str "{{<hd>}|(let)|<tl>}") unique_ident
      in
      add_edge g src dst ~dstport ~edgename;
      add_expression g ~dst:src ~dstport:"hd" exp ~edgename
  | Texp_function { arg_label; param; cases; _ } ->
      let rec srcportlist =
        String.concat "|"
          (List.mapi (fun i _ -> F.str "<%d>" i) cases)
      in
      let src =
        make_vertex
          ~label:
            (F.str "{{%s}|fun %s:%s|<tl>}" srcportlist
               (Printtyp.string_of_label arg_label)
               (Ident.name param))
          (Ident.unique_name param)
      in
      add_edge g src dst ~edgename;
      List.iter
        (fun { c_lhs; c_guard; c_rhs } ->
          let srcportlist =
            match c_guard with Some _ -> "<with>|" | None -> ""
          in
          let src =
            make_vertex
              ~label:
                (F.str "{{%s<hd>}|%a with %s|<tl>}" srcportlist
                   Printpat.top_pretty c_lhs (Ident.name param))
              (Ident.unique_name param)
          in
          Option.iter
            (fun exp ->
              add_expression g ~dst:src ~dstport:"with" exp ~edgename)
            c_guard;

          add_edge g src dst ~edgename;
          add_expression g ~dst:src ~dstport:"hd"
            ~edgename:(Printtyp.string_of_label arg_label)
            c_rhs)
        cases
  | Texp_match (exp0, cases, _partial) ->
      let rec dstportlist =
        String.concat "|"
          (List.mapi
             (fun i { c_lhs; c_guard; _ } ->
               F.str "<%d>%s%s" i (P.str_of_pat c_lhs)
                 (Option.fold ~none:""
                    ~some:(fun _ -> F.str "|with<with%d>" i)
                    c_guard))
             cases)
      in
      let src =
        make_vertex
          ~label:(F.str "{{<match>with|%s}|(match)|<tl>}" dstportlist)
          unique_ident
      in
      add_edge g src dst ~dstport ~edgename;
      add_expression g ~dst:src ~dstport:"match" ~edgename exp0;
      List.iteri
        (fun i { c_guard; c_rhs; _ } ->
          Option.iter
            (fun exp_guard ->
              add_expression g ~dst:src ~dstport:(F.str "with%d" i)
                ~edgename exp_guard)
            c_guard;
          add_expression g ~dst:src ~dstport:(F.str "%d" i) ~edgename
            c_rhs)
        cases
  | Texp_tuple tl ->
      let rec dstportlist =
        String.concat "|"
          (List.mapi (fun i _ -> F.str "<%d>%d" i i) tl)
      in
      let src =
        make_vertex
          ~label:(F.str "{{%s}|(tuple)|<tl>}" dstportlist)
          unique_ident
      in
      add_edge g src dst ~dstport ~edgename;
      List.iteri
        (fun i e ->
          add_expression g ~dst:src ~dstport:(F.str "%d" i) ~edgename
            e)
        tl
  | Texp_construct (li, _constr_desc, exp_list) ->
      let rec dstportlist =
        String.concat "|"
          (List.mapi (fun i _ -> F.str "<%d>%d" i i) exp_list)
      in
      let src =
        make_vertex
          ~label:
            (F.str "{{%s}|%a (construct)|<tl>}" dstportlist
               P.fmt_longident li)
          unique_ident
      in
      add_edge g src dst ~dstport ~edgename;
      List.iteri
        (fun i e ->
          add_expression g ~dst:src ~dstport:(F.str "%d" i) ~edgename
            e)
        exp_list
  | e ->
      let src =
        make_vertex
          ~label:(F.str "{%s|<tl>}" (P.string_of_texp e))
          unique_ident
      in
      add_edge g src dst

and add_node_edges g t dst : unit =
  let unique_ident = F.str "/%d" !ident_counter in
  ident_counter := !ident_counter + 1;
  match Browse_tree.(t.t_node) with
  | Expression e -> add_expression g ~dst ~dstport:"hd" ~edgename:"" e
  | node ->
      let src_name, src_ident =
        match node with
        | Pattern p ->
            let fmt, printer = Std.Format.to_string () in
            Printpat.top_pretty fmt p;
            (printer (), unique_ident)
        | e -> (P.string_of_node e, unique_ident)
      in
      let src =
        make_vertex src_ident ~label:(F.str "{<hd>|%s|<tl>}" src_name)
      in
      add_edge g src dst;
      graph_of_browse g src (Lazy.force t.t_children)

and graph_of_browse g dst (tl : Browse_tree.t list) =
  match tl with
  | t :: ts ->
      add_node_edges g t dst;
      graph_of_browse g dst ts
  | [] -> ()

let merlin_parse str : Gr.t =
  let config, _command_args =
    Mconfig.parse_arguments ~wd:(Sys.getcwd ())
      ~warning:(fun _ -> ())
      (List.map snd []) [] Mconfig.initial []
  in
  File_id.with_cache @@ fun () ->
  let source = Msource.make str in
  let pipeline = Mpipeline.make config source in
  Mpipeline.with_pipeline pipeline @@ fun () ->
  Log.info (fun m -> m "merlin_parse...");
  let typer = Mpipeline.typer_result pipeline in
  let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
  Log.info (fun m -> m "Mbrowse.print %s" (Mbrowse.print () browse));
  let g = Gr.create [ `Rankdir `LeftToRight ] in
  let dst =
    make_vertex "root" ~attr:[ `Label (F.str "{<hd>|root|<tl>}") ]
  in
  graph_of_browse g dst
    (Lazy.force (Browse_tree.of_browse browse).t_children);
  g

(* match typedtree with
   | `Implementation t ->
       Log.info (fun m ->
           m "Untyped:@ %a" Pprintast.structure
             Pmapper.(
               remove_attributes.structure remove_attributes
                 (Untypeast.untype_structure t)));
       Log.info (fun m ->
           m "Printtyped:@ %a" Ocaml_typing.Printtyped.implementation t);
       graph_of_impl t
     | `Interface _ -> Gr.create [] *)

let dot_of_tast ?(fname = "x.dot") str : unit =
  let oc = open_out fname in
  Dot.output_graph oc (merlin_parse str);
  close_out oc