it goes pretty far

`Dot_of_tast.dot_of_tast "let rec fact n = if n = 0 then 1. else float n *. fact (n - 1) ;; module A = struct let b = 0. let derp = Some [true, false], 'h', 3. +. (4. *. 6.)  end  ";;`

lib/dot_of_tast.ml

@@ -51,6 +51,8 @@ digraph {
  *)
 
 open Merlin_kernel
+open Merlin_analysis
+open Merlin_specific
 open Merlin_utils
 open Ocaml_parsing
 open Ocaml_typing
@@ -59,11 +61,16 @@ let _ =
   Logs.set_reporter (Logs_fmt.reporter ());
   Logs.set_level (Some Debug)
 
-module F = Fmt
+module F = struct
+  include Fmt
 
-module Log = (val Logs.src_log
-                    (Logs.Src.create "dot_of_tast"
-                       ~doc:"dot_of_tast.ml logger") : Logs.LOG)
+  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
 
@@ -671,10 +678,12 @@ module Pmapper = struct
 end
 
 (* Stolen from ocaml/typing/printtyped.ml cause it's not exposed!! *)
-module P = struct
+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 =
@@ -696,6 +705,21 @@ module P = struct
     | 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) =
@@ -704,7 +728,21 @@ let str_of_exp (exp : Typedtree.expression) =
       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"
@@ -714,15 +752,21 @@ let pp_value_binding_list ppf (vbl : Typedtree.value_binding list) =
 
 let unique_node_count = ref 0
 
-let vertex_of_primary_value (exp : Typedtree.expression) : Gr.Vertex.t
-    =
+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" P.fmt_path path;
-        attr = [ `Label (F.str "{{<0>}|<out>%s}" (str_of_exp exp)) ];
+        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
@@ -732,105 +776,153 @@ let vertex_of_primary_value (exp : Typedtree.expression) : Gr.Vertex.t
   | Texp_variant _ -> { Gr.Vertex.default with name = str_of_exp exp }
   | Texp_apply (exp, args) ->
       let cnt = ref 0 in
-      {
-        Gr.Vertex.default with
-        name = str_of_exp exp;
-        attr =
-          [
-            `Label
-              (F.str "{{%a}|<o>%s}"
-                 (F.list
-                    ~sep:(fun ppf () -> F.string ppf "|")
-                    (fun ppf arg_list ->
-                      match arg_list with
+      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));
-          ];
-      }
-  | Texp_function { arg_label = _; param; cases = _; partial = _ } ->
+          args (str_of_exp exp)
+      in
       {
         Gr.Vertex.default with
-        name = Fmt.str "fun %s" (str_of_ident param);
+        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 (_, _, Some _) ->
-      {
-        Gr.Vertex.default with
-        (* TODO make unique (with loc?) *)
-        name = "if/then/else";
-        attr = [ `Label "{{<0>if|<1>then|<2>else}|<o>}" ];
-      }
-  | Texp_ifthenelse (_, _, None) ->
-      {
-        Gr.Vertex.default with
-        name = Fmt.str "if/then";
-        attr = [ `Label "{{<1>if|<2>then}|<o>}" ];
-      }
+  | Texp_ifthenelse (_, _, _) -> Gr.Vertex.default
   | _ ->
       {
         Gr.Vertex.default with
         name = Fmt.str "???? (%s)" (str_of_exp exp);
       }
 
-let graph_of_impl (s : Typedtree.structure) : Gr.t =
-  let g = Gr.create [ `Rankdir `LeftToRight ] in
-  let sdst : (Gr.V.t * int) Stack.t = Stack.create () in
-  let iterator =
-    {
-      Tast_iterator.default_iterator with
-      expr =
-        (fun iter exp ->
-          let src = vertex_of_primary_value exp in
+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
-          Log.debug (fun m -> m "src: %s" (Gr.Vertex.label src));
   incr unique_node_count;
-          (match exp.exp_desc with
+  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) sdst;
+                Stack.push (src, i) dst_stk;
                 iter.expr iter ee;
-                      Stack.pop sdst |> ignore)
+                Stack.pop dst_stk |> ignore)
               expopt;
-                  match arg_label with
-                  | Asttypes.Nolabel -> i + 1
-                  | _ -> i)
+            match arg_label with Asttypes.Nolabel -> i + 1 | _ -> i)
           0 list
-              |> ignore
+        |> ignore;
+        src
     | Texp_ifthenelse (e0, e1, e2) ->
-              Stack.push (src, 0) sdst;
+        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 sdst |> ignore;
-              Stack.push (src, 1) sdst;
+        Stack.pop dst_stk |> ignore;
+        Stack.push (src, 1) dst_stk;
         iter.expr iter e1;
-              Stack.pop sdst |> ignore;
+        Stack.pop dst_stk |> ignore;
         Option.iter
           (fun e' ->
-                  Stack.push (src, 2) sdst;
+            Stack.push (src, 2) dst_stk;
             iter.expr iter e';
-                  Stack.pop sdst |> ignore)
-                e2
+            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
     | _ ->
-              Stack.push (src, 0) sdst;
+        let src = vertex_of_exp exp in
+        Stack.push (src, 0) dst_stk;
         Tast_iterator.default_iterator.expr iter exp;
-              Stack.pop sdst |> ignore);
-          match Stack.top_opt sdst with
+        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));
+          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.
@@ -843,14 +935,395 @@ let graph_of_impl (s : Typedtree.structure) : Gr.t =
                 ];
             },
           dst )
-          | None -> ());
-    }
+  | 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;
-  Log.info (fun m ->
-      m "g_of_impl Printtyped:@ %a" Printtyped.implementation 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 ())
@@ -863,17 +1336,27 @@ let merlin_parse str : Gr.t =
   Mpipeline.with_pipeline pipeline @@ fun () ->
   Log.info (fun m -> m "merlin_parse...");
   let typer = Mpipeline.typer_result pipeline in
-  let typedtree = Mtyper.get_typedtree typer in
-  let _mbrowse = Mbrowse.of_typedtree typedtree in
-  match typedtree with
+  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
-            (Untypeast.untype_structure t));
+             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 []
+     | `Interface _ -> Gr.create [] *)
 
 let dot_of_tast ?(fname = "x.dot") str : unit =
   let oc = open_out fname in

lib/dune

@@ -3,6 +3,23 @@
 
 (library
  (name dot_of_tast)
+  (modules dot_of_tast)
+ (libraries
+   logs.fmt
+   fmt
+   merlin-lib.kernel
+   merlin-lib.analysis
+   merlin-lib.ocaml_merlin_specific
+   merlin-lib.ocaml_utils
+   merlin-lib.ocaml_preprocess
+   merlin-lib.ocaml_parsing
+   merlin-lib.ocaml_typing
+   ocamlgraph
+))
+
+(library
+ (name graph_of_tast)
+  (modules graph_of_tast)
  (libraries
    logs.fmt
    fmt

notes.org

@@ -1,4 +1,16 @@
+* usage:
 
+evaulate the following in ur ocaml toplevel (`$ ocaml`):
+
+```
+#use_output "dune ocaml top";;
+Dot_of_tast.dot_of_tast "let rec fact n = if n = 0 then 1. else float n *. fact (n - 1)";;
+```
+
+run in shell to see output:
+```
+$ xdot x.dot
+```
 
 
 ** current development pattern