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 = begin 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"
end

let rec print_links (acc:Js.js_string Js.t) = begin 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
end

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

let rec parse lexbuf acc current_name level links = begin
  try
    begin 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' = begin match target with
          | None -> links
          | Some (target, comment, arrow) -> (current_name, level', target, comment, arrow)::links
        end 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
    end
  with Tab_Lexer.Eof ->
    if (level >= 0) then (
      let text = Js.string "</TABLE>>];\n" in
      print_links (acc##concat text) links;
    ) else
      acc
end

let convert source = begin

  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 "}")
end