Added viz.js code

5 files changed, 230 insertions, 0 deletions

diff --git a/viz.js/process/dune b/viz.js/process/dune
new file mode 100755
index 0000000..fba62e8
--- /dev/null
+++ b/viz.js/process/dune
@@ -0,0 +1,10 @@
+(ocamllex tab_Lexer)
+
+(library
+ (name process)
+ (libraries 
+   js_of_ocaml 
+   promise
+   )
+ (preprocess (pps js_of_ocaml-ppx))
+ )
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
diff --git a/viz.js/process/process.ml b/viz.js/process/process.ml
new file mode 100755
index 0000000..ef23b78
--- /dev/null
+++ b/viz.js/process/process.ml
@@ -0,0 +1,29 @@
+open Js_of_ocaml
+
+class type viz = object
+  (* PNG output *)
+  method renderImageElement: Js.js_string Js.t -> (Dom_html.imageElement Js.t, unit) Promise.promise Js.meth
+  (* SVG output *)
+  method renderSVGElement: Js.js_string Js.t -> (Dom_svg.svgElement Js.t, unit) Promise.promise Js.meth
+
+  method renderString: Js.js_string Js.t -> (Js.js_string Js.t, unit) Promise.promise Js.meth
+end
+
+type t = Js.js_string Js.t * Js.js_string Js.t
+
+let do_action
+  : viz Js.t -> Js.js_string Js.t -> (unit, unit) Promise.promise
+  = fun v text ->
+
+    if text##.length != 0 then (
+      let gv = Formatter.convert text in
+      let promise =
+        (try v##renderString gv
+         with _ -> Promise.reject ()
+        ) in
+      Promise.then_map
+        ~on_fulfilled:(fun svg -> Worker.post_message ((gv, svg):t))
+        ~on_rejected:(fun _ -> ())
+        promise
+    ) else
+      Promise.reject ()
diff --git a/viz.js/process/tab_Lexer.mll b/viz.js/process/tab_Lexer.mll
new file mode 100755
index 0000000..67793e4
--- /dev/null
+++ b/viz.js/process/tab_Lexer.mll
@@ -0,0 +1,65 @@
+{
+  open Js_of_ocaml
+  exception SyntaxError of string * Lexing.lexbuf
+  exception Eof
+
+  type arrow =
+  | Forward
+  | Backward
+  | Both
+  | None
+
+  type jstring = Js.js_string Js.t
+
+  type res = 
+  | NewLine
+  | Root of jstring
+  | Entry of jstring * (jstring * jstring * arrow) option
+  | Redirection of jstring * jstring * arrow
+  | Separator
+
+  let get_arrow = begin function
+  | "<-" -> Backward
+  | "<->" -> Both
+  | "--" -> None
+  | _ -> Forward
+  end
+
+}
+
+let space = ['\000' '\t' '\x0C' ' '] 
+let spaces = space*
+let newline = spaces ("\r\n" | '\n' | '\r')+
+
+(* Any character except the delimiters and spaces *)
+let regular = [^ '\n' '\x0C' '\r' ]
+let target_id = ['A'-'Z' 'a'-'z' '0'-'9']+ (':' ['0'-'9']+)?
+
+let arrow = "->" | "--" | "<-" | "<->"
+
+rule parse_line = shortest
+  | eof            { raise Eof }
+
+  | newline  {NewLine}
+
+  | space+ '-'+ newline {Separator}
+
+  | (target_id as _1) newline        { Root (Js.string _1) }
+
+  | (spaces as _1) 
+    (arrow as _arrow) space+ 
+    (target_id as _target) spaces 
+    (regular* as comment) newline 
+        { Redirection ( Js.string _target, Js.string comment, (get_arrow _arrow))}
+
+  | spaces
+    (regular+ as _2) space+ 
+    (arrow as _arrow) space+ 
+    (target_id as _target) spaces 
+    (regular* as comment) newline 
+        { Entry (Js.string _2, Some (Js.string _target, Js.string comment, (get_arrow _arrow)))}
+
+  | (space+ as _1) 
+    (regular+ as _2) newline
+        { Entry (Js.string _2, None) }
+
diff --git a/viz.js/process/tools.ml b/viz.js/process/tools.ml
new file mode 100755
index 0000000..c5e39b1
--- /dev/null
+++ b/viz.js/process/tools.ml
@@ -0,0 +1,26 @@
+let drop_while predicate =
+  let rec _drop = function
+    | [] -> []
+    | (hd::tl) as l ->
+      if predicate hd then
+        _drop tl
+      else
+        l
+  in _drop
+
+(* Split a text and and new line before it goes to long *)
+let split limit =
+  let rec _split elms text =
+    let length = (String.length text) -1 in
+    if (length < limit) then
+      List.rev (text::elms)
+      |> String.concat "\\n"
+    else
+      try
+        let pos = String.rindex_from text limit ' ' in
+        let hd = String.sub text 0 pos
+        and tl = String.sub text (pos +1) (length - pos) in
+        _split (hd::elms) tl
+      with Not_found -> text
+  in _split []
+