console/tastsch
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

even closer

Browse Source
This commit is contained in:
cqc
2023-04-05 14:42:42 -05:00
parent 54fb79fa5d
commit 5451b2be40
1 changed files with 57 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

71
lib/dot_of_tast.ml
View File

@ -670,6 +670,34 @@ module Pmapper = struct
{ default with attributes = (fun _m _alist -> []) }
end
(* Stolen from ocaml/typing/printtyped.ml cause it's not exposed!! *)
module P = struct
open Format
open Lexing
open Location
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
end
let str_of_exp (exp : Typedtree.expression) =
Fmt.str "%a" Pprintast.expression
Pmapper.(
@ -677,7 +705,6 @@ let str_of_exp (exp : Typedtree.expression) =
(Untypeast.untype_expression exp))
let str_of_ident = Ident.name
(*let unique_str_of_ident = Ident.unique_toplevel_name*)
let pp_value_binding_list ppf (vbl : Typedtree.value_binding list) =
Fmt.pf ppf "%a"
@ -685,17 +712,24 @@ let pp_value_binding_list ppf (vbl : Typedtree.value_binding list) =
(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_primary_value (exp : Typedtree.expression) : Gr.Vertex.t
=
match exp.exp_desc with
| Texp_ident _ ->
| Texp_ident (path, _longident, _value_desc) ->
{
name = str_of_exp exp;
attr = [ `Label (F.str "%s" (str_of_exp exp)) ];
name = F.str "%a" P.fmt_path path;
attr = [ `Label (F.str "{{<0>}|<out>%s}" (str_of_exp exp)) ];
subgraph = None;
}
| Texp_constant _ | Texp_variant _ ->
{ Gr.Vertex.default with name = 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
{
@ -732,7 +766,7 @@ let vertex_of_primary_value (exp : Typedtree.expression) : Gr.Vertex.t
Gr.Vertex.default with
(* TODO make unique (with loc?) *)
name = "if/then/else";
attr = [ `Label "{{<1>if|<2>then|<3>else}|<o>}" ];
attr = [ `Label "{{<0>if|<1>then|<2>else}|<o>}" ];
}
| Texp_ifthenelse (_, _, None) ->
{
@ -755,8 +789,9 @@ let graph_of_impl (s : Typedtree.structure) : Gr.t =
expr =
(fun iter exp ->
let src = vertex_of_primary_value exp in
let srcport = "<o>" in
let srcport = "out" in
Log.debug (fun m -> m "src: %s" (Gr.Vertex.label src));
incr unique_node_count;
(match exp.exp_desc with
| Texp_apply (_exp, list) ->
(* Tast_iterator.default_iterator.expr iter exp *)
@ -774,6 +809,19 @@ let graph_of_impl (s : Typedtree.structure) : Gr.t =
| _ -> i)
0 list
|> ignore
| Texp_ifthenelse (e0, e1, e2) ->
Stack.push (src, 0) sdst;
iter.expr iter e0;
Stack.pop sdst |> ignore;
Stack.push (src, 1) sdst;
iter.expr iter e1;
Stack.pop sdst |> ignore;
Option.iter
(fun e' ->
Stack.push (src, 2) sdst;
iter.expr iter e';
Stack.pop sdst |> ignore)
e2
| _ ->
Stack.push (src, 0) sdst;
Tast_iterator.default_iterator.expr iter exp;
@ -795,12 +843,7 @@ let graph_of_impl (s : Typedtree.structure) : Gr.t =
];
},
dst )
| None -> ())
(*
Tast_iterator.default_iterator.expr iter exp;
Log.info (fun m ->
m "dot_of_impl unknown:@ %a" Pprintast.expression
(Untypeast.untype_expression exp))) *);
| None -> ());
}
in
iterator.structure iterator s;