open Js_of_ocaml
module T = Tools

let leftright = false

module Printer = struct
  type t = Js.js_string Js.t

  let inject = Js.string
  let print2 t t1 t2 = t##concat_2 t1 t2
  let print4 t t1 t2 t3 t4 = t##concat_4 t1 t2 t3 t4
  let print5 t t1 t2 t3 t4 t5 = (t##concat t1)##concat_4 t2 t3 t4 t5

  let print10 t t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 =
    ((t##concat_4 t1 t2 t3 t4)##concat_3 t5 t6 t7)##concat_3 t8 t9 t10
end

let print_arrow = function
  | Tab_Lexer.Backward -> Printer.inject "back"
  | Tab_Lexer.Both -> Printer.inject "both"
  | Tab_Lexer.None -> Printer.inject "none"
  | Tab_Lexer.Forward -> Printer.inject "forward"

let rec print_links (acc : Js.js_string Js.t) = function
  | [] -> acc
  | (current_name, level, target, comment, arrow) :: tl ->
      let acc' =
        Printer.print10 acc current_name (Printer.inject ":")
          (Printer.inject @@ string_of_int level)
          (Printer.inject " -> ") target
          (Printer.inject "[label=\"")
          comment
          (Printer.inject "\" dir=\"")
          (print_arrow arrow) (Printer.inject "\" ]\n")
      in
      print_links acc' tl

let shape =
  Printer.inject
    "[label=<<TABLE BORDER=\"0\" CELLBORDER=\"1\" CELLSPACING=\"0\">"

let rec parse lexbuf acc current_name level links =
  try
    match Tab_Lexer.parse_line lexbuf with
    | Root content ->
        let acc' = Printer.print2 acc content shape in
        parse lexbuf acc' content 0 links
    | Entry (content, target) ->
        let level' = level + 1 in
        let acc' =
          (acc##concat_4
             (Js.string "<TR><TD port=\"")
             (Js.string @@ string_of_int level')
             (Js.string "\">") content)##concat
            (Js.string "</TD></TR>")
        in
        let links' =
          match target with
          | None -> links
          | Some (target, comment, arrow) ->
              (current_name, level', target, comment, arrow) :: links
        in
        parse lexbuf acc' current_name level' links'
    | Redirection (target, comment, arrow) ->
        let links' = (current_name, level, target, comment, arrow) :: links in
        parse lexbuf acc current_name level links'
    | NewLine ->
        let acc' =
          if level >= 0 then
            print_links (acc##concat (Js.string "</TABLE>>];\n")) links
          else acc
        in
        parse lexbuf acc' (Js.string "") (-1) []
    | Separator ->
        let text = "<TR><TD></TD></TR>" in
        parse lexbuf (acc##concat (Js.string text)) current_name level links
  with
  | Tab_Lexer.Eof ->
      if level >= 0 then
        let text = Js.string "</TABLE>>];\n" in
        print_links (acc##concat text) links
      else acc

let convert source =
  let text = Js.string "digraph G {rankdir=LR;node [shape=plaintext];" in
  (* Content *)
  let lexbuf =
    Lexing.from_string (Js.to_string (source##concat (Js.string "\r\n")))
  in
  (parse lexbuf text (Js.string "") 0 [])##concat (Js.string "}")