summaryrefslogtreecommitdiff
path: root/viz.js/process
diff options
context:
space:
mode:
Diffstat (limited to 'viz.js/process')
-rwxr-xr-xviz.js/process/dune10
-rwxr-xr-xviz.js/process/formatter.ml100
-rwxr-xr-xviz.js/process/process.ml29
-rwxr-xr-xviz.js/process/tab_Lexer.mll65
-rwxr-xr-xviz.js/process/tools.ml26
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 []
+