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 ";;`
This commit is contained in:
cqc
@ -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
|
||||
(Logs.Src.create "dot_of_tast"
|
||||
~doc:"dot_of_tast.ml logger") : Logs.LOG)
|
||||
module Log =
|
||||
(val Logs.src_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,144 +806,524 @@ let vertex_of_exp (exp : Typedtree.expression) : Gr.Vertex.t =
|
||||
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 dst_stk : (Gr.V.t * int) Stack.t = Stack.create () in
|
||||
let expr (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 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,21 +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 _initial_env = Mtyper.initial_env typer in
|
||||
let mbrowse = Mbrowse.of_typedtree typedtree in
|
||||
Log.info (fun m -> m "Mbrowse.print %s" (Mbrowse.print () mbrowse));
|
||||
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 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
|
||||
|
||||
Reference in New Issue
Block a user