1 files changed, 100 insertions, 0 deletions
diff --git a/viz.js/process/formatter.ml b/viz.js/process/formatter.ml
new file mode 100755
index 0000000..e6a8a0e
--- /dev/null
+++ b/viz.js/process/formatter.ml
@@ -0,0 +1,100 @@
+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