From 77544bdfad2af41514ec1435f706fee87ea2969e Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Mon, 7 Feb 2022 15:38:37 +0100 Subject: Added viz.js code --- viz.js/process/dune | 10 +++++ viz.js/process/formatter.ml | 100 +++++++++++++++++++++++++++++++++++++++++++ viz.js/process/process.ml | 29 +++++++++++++ viz.js/process/tab_Lexer.mll | 65 ++++++++++++++++++++++++++++ viz.js/process/tools.ml | 26 +++++++++++ 5 files changed, 230 insertions(+) create mode 100755 viz.js/process/dune create mode 100755 viz.js/process/formatter.ml create mode 100755 viz.js/process/process.ml create mode 100755 viz.js/process/tab_Lexer.mll create mode 100755 viz.js/process/tools.ml (limited to 'viz.js/process') 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=<") + +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 "") + 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 "
") + content + )##concat + (Js.string "
>];\n")) links; + ) else ( + acc + ) in + parse lexbuf acc' (Js.string "") (-1) [] + | Separator -> + let text = "" 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 ">];\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 [] + -- cgit v1.2.3