1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
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 = 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"
let rec print_links (acc : Js.js_string Js.t) = 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
let shape =
Printer.inject
"[label=<<TABLE BORDER=\"0\" CELLBORDER=\"1\" CELLSPACING=\"0\">"
let rec parse lexbuf acc current_name level links =
try
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' =
match target with
| None -> links
| Some (target, comment, arrow) ->
(current_name, level', target, comment, arrow) :: links
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
with
| Tab_Lexer.Eof ->
if level >= 0 then
let text = Js.string "</TABLE>>];\n" in
print_links (acc##concat text) links
else acc
let convert source =
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 "}")
|
