let to_dot t ~parameters =
let open SmartPrint in
let semicolon = string ";" in
let sentence sp = sp ^-^ semicolon ^-^ newline in
let dot_attributes l =
brakets (
List.map l ~f:(fun (k, v) ->
string k ^^ string "=" ^^ v) |> separate (semicolon)
) in
let in_quotes s = ksprintf string "\"%s\"" s in
let label_attribute lab = ("label", in_quotes lab) in
let font_name `Mono =
("fontname", in_quotes "monospace") in
let font_size =
function
| `Small -> ("fontsize", in_quotes "12")
| `Default -> ("fontsize", in_quotes "16")
in
let dot_arrow src dest = string src ^^ string "->" ^^ string dest in
let id_of =
function
| `Lambda (id, _, _) -> id
| `Apply (id, _, _) -> id
| `Variable (id, _) -> id
| `String s -> assert false
| `Input_value {id; _} -> id
| `Node ({id; _}, _) -> id in
let label name attributes =
match attributes with
| [] -> name
| _ ->
sprintf "{<f0>%s |<f1> %s\\l }" name
(List.map attributes ~f:(fun (k,v) -> sprintf "%s: %s" k v)
|> String.concat "\\l")
in
let one o = [o] in
let rec go =
function
| `Variable (_, s) as v ->
let id = id_of v in
sentence (
string id ^^ dot_attributes [
label_attribute (label s []);
font_name `Mono;
"shape", in_quotes "hexagon";
]
)
|> one
| `Lambda (id, v, expr) ->
[
string "subgraph" ^^ ksprintf string "cluster_%s" id ^^ braces (
(
sentence (string "color=grey")
:: sentence (string "style=rounded")
:: sentence (string "penwidth=4")
:: go (node ~id (sprintf "Lambda %s" v) [arrow "Expr" expr])
)
|> List.dedup |> separate empty
) ^-^ newline
]
| `Apply (id, f, v) ->
go (node ~id "Apply F(X)" [arrow "F" f; arrow "X" v])
| `String s ->
failwithf "`String %S -> should have been eliminated" s
| `Input_value {id; name; attributes} ->
let color =
parameters.color_input ~name ~attributes
|> Option.value ~default:"black"
in
sentence (
string id ^^ dot_attributes [
label_attribute (label name attributes);
font_name `Mono;
"shape", in_quotes "Mrecord";
"color", in_quotes color;
]
)
|> one
| `Node ({id; name; attributes}, trees) ->
sentence (
string id ^^ dot_attributes [
label_attribute (label name attributes);
font_name `Mono;
"shape", in_quotes "Mrecord";
]
)
:: List.concat_map trees ~f:(fun {label; points_to} ->
sentence (
dot_arrow (id_of points_to) id ^^ dot_attributes [
label_attribute label;
font_size `Small;
]
)
:: go points_to
)
in
let dot =
string "digraph target_graph" ^^ braces (nest (
sentence (
string "graph" ^^ dot_attributes [
"rankdir", in_quotes "LR";
font_size `Default;
]
)
^-^ (go t |> List.dedup |> separate empty)
))
in
dot