open Ast
module IntSet = Set.Make (Int)

let add_node (fmt : Format.formatter) (i : expr index) (expr : expr) : unit =
  match expr with
  | App _ ->
      Format.fprintf fmt
        "  expr%d [fontname=\"CMU Typewriter Text Bold\", label=\"apply\"];\n"
        i.index
  | Cons _ ->
      Format.fprintf fmt
        "  expr%d [fontname=\"CMU Typewriter Text Bold\", label=\"::\"];\n"
        i.index
  | Int n -> Format.fprintf fmt "  expr%d [label=\"%d\"];\n" i.index n
  | Lam _ -> Format.fprintf fmt "  expr%d [label=\"λ\"];\n" i.index
  | Nil ->
      Format.fprintf fmt
        "  expr%d [fontname=\"CMU Typewriter Text Bold\", label=\"[]\"];\n"
        i.index
  | Prim (Add, _) -> Format.fprintf fmt "  expr%d [label=\"+\"];\n" i.index
  | Prim (Sub, _) -> Format.fprintf fmt "  expr%d [label=\"-\"];\n" i.index
  | Prim (Mul, _) -> Format.fprintf fmt "  expr%d [label=\"*\"];\n" i.index
  | Var x -> Format.fprintf fmt "  expr%d [label=%S];\n" i.index x

let add_expr_edges (ast : 'a ast) (fmt : Format.formatter)
    (nodes : IntSet.t ref) : expr index -> unit =
  let rec loop (i : expr index) : unit =
    nodes := IntSet.add i.index !nodes;
    let edge_to (j : expr index) : unit =
      loop j;
      Format.fprintf fmt "  expr%d -> expr%d;\n" i.index j.index
    in
    match get_subexpr ast i with
    | App (f, x) ->
        edge_to f;
        edge_to x
    | Cons (hd, tl) ->
        edge_to hd;
        edge_to tl
    | Lam (x, b) ->
        Format.fprintf fmt "  expr%d -> expr%d_var;\n" i.index i.index;
        Format.fprintf fmt "  expr%d_var [label=%S];\n" i.index x;
        edge_to b
    | Prim (Add, (l, r)) ->
        edge_to l;
        edge_to r
    | Prim (Sub, (l, r)) ->
        edge_to l;
        edge_to r
    | Prim (Mul, (l, r)) ->
        edge_to l;
        edge_to r
    | Var _ -> ()
    | Int _ | Nil -> ()
  in
  loop

let draw_tree (ast : expr ast) : string =
  let buf = Buffer.create 16 and nodes = ref IntSet.empty in
  let fmt = Format.formatter_of_buffer buf in
  Format.fprintf fmt "digraph {\n";
  add_expr_edges ast fmt nodes ast.root;
  Format.fprintf fmt "\n";
  IntSet.iter
    (fun index ->
      let i = { index } in
      add_node fmt i (get_subexpr ast i))
    !nodes;
  Format.fprintf fmt "}\n";
  Format.pp_print_flush fmt ();
  Buffer.contents buf