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
@@ -65,9 +67,10 @@ module F = struct
   let bar ppf () = string ppf "|"
 end
 
-module Log = (val Logs.src_log
+module Log =
-                    (Logs.Src.create "dot_of_tast"
+  (val Logs.src_log
-                       ~doc:"dot_of_tast.ml logger") : Logs.LOG)
+         (Logs.Src.create "dot_of_tast" ~doc:"dot_of_tast.ml logger")
+      : Logs.LOG)
 
 open Graph
 
@@ -675,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 =
@@ -700,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) =
@@ -721,7 +741,7 @@ 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" P.fmt_ident s
+  | 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) =
@@ -737,7 +757,7 @@ let vertex_of_exp (exp : Typedtree.expression) : Gr.Vertex.t =
   match exp.exp_desc with
   | Texp_ident (path, _longident, _value_desc) ->
       {
-        name = F.str "%a" P.fmt_path path;
+        name = F.str "%a" Pp.fmt_path path;
         attr = [ `Label (F.str "{{<in>}|<out>%s}" (str_of_exp exp)) ];
         subgraph = None;
       }
@@ -786,10 +806,9 @@ let vertex_of_exp (exp : Typedtree.expression) : Gr.Vertex.t =
 let labeled_vertex name label =
   { Gr.Vertex.default with name; attr = [ `Label label ] }
 
-let graph_of_impl (s : Typedtree.structure) : Gr.t =
+let dst_stk : (Gr.V.t * int) Stack.t = Stack.create ()
-  let g = Gr.create [ `Rankdir `LeftToRight ] in
+
-  let dst_stk : (Gr.V.t * int) Stack.t = Stack.create () in
+let expr_iterator g (iter : Tast_iterator.iterator)
-  let expr (iter : Tast_iterator.iterator)
     (exp : Typedtree.expression) =
   let extra = function
     | Typedtree.Texp_constraint cty -> iter.typ iter cty
@@ -820,9 +839,7 @@ let graph_of_impl (s : Typedtree.structure) : Gr.t =
                 iter.expr iter ee;
                 Stack.pop dst_stk |> ignore)
               expopt;
-              match arg_label with
+            match arg_label with Asttypes.Nolabel -> i + 1 | _ -> i)
-              | Asttypes.Nolabel -> i + 1
-              | _ -> i)
           0 list
         |> ignore;
         src
@@ -919,11 +936,394 @@ let graph_of_impl (s : Typedtree.structure) : Gr.t =
             },
           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
-  let iterator = { Tast_iterator.default_iterator with expr } 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 ())
@@ -936,11 +1336,17 @@ 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 browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
-  let _initial_env = Mtyper.initial_env typer in
+  Log.info (fun m -> m "Mbrowse.print %s" (Mbrowse.print () browse));
-  let mbrowse = Mbrowse.of_typedtree typedtree in
+  let g = Gr.create [ `Rankdir `LeftToRight ] in
-  Log.info (fun m -> m "Mbrowse.print %s" (Mbrowse.print () mbrowse));
+  let dst =
-  match typedtree with
+    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
@@ -950,7 +1356,7 @@ let merlin_parse str : Gr.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