aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xcss/merger.ml367
-rwxr-xr-xlib/application/dune1
-rwxr-xr-xviz.js/process/formatter.ml114
-rwxr-xr-xviz.js/process/tab_Lexer.mll2
4 files changed, 209 insertions, 275 deletions
diff --git a/css/merger.ml b/css/merger.ml
index ea6efe2..24c10a3 100755
--- a/css/merger.ml
+++ b/css/merger.ml
@@ -1,48 +1,42 @@
open StdLabels
open Js_of_ocaml
-
open Brr
open Note
open Brr_note
-
module Printer = Css_lib.Print
let min = Printer.minify_printer
-type file =
- { file : File.t
+type file = {
+ file : File.t
; css : Css.Types.Stylesheet.t option
- }
+}
-type state =
- { files : file Js.js_array Js.t
+type state = {
+ files : file Js.js_array Js.t
; result_css : Css.Types.Stylesheet.t option
; elements : int
- }
-
-module App = Application.Make(struct type t = state end)
-
-let init =
- { files = new%js Js.array_empty
- ; result_css = None
- ; elements = 0 }
-
-let build_result
- : file Js.js_array Js.t -> Css.Types.Stylesheet.t option
- = fun documents ->
- let merge_result = documents##reduce_init
- (Js.wrap_callback @@
- (fun acc v _idx _arr ->
-
- match acc, v.css with
- | None, None -> None
- | None, Some css -> Some (Css_lib.Merge.(add_css empty css))
- | Some res, Some css -> Some (Css_lib.Merge.(add_css res css ))
- | v, None -> v ))
- None in
- Option.map
- Css_lib.Merge.extract_css
- merge_result
+}
+
+module App = Application.Make (struct
+ type t = state
+end)
+
+let init = { files = new%js Js.array_empty; result_css = None; elements = 0 }
+
+let build_result : file Js.js_array Js.t -> Css.Types.Stylesheet.t option =
+ fun documents ->
+ let merge_result =
+ documents##reduce_init
+ ( Js.wrap_callback @@ fun acc v _idx _arr ->
+ match (acc, v.css) with
+ | None, None -> None
+ | None, Some css -> Some Css_lib.Merge.(add_css empty css)
+ | Some res, Some css -> Some Css_lib.Merge.(add_css res css)
+ | v, None -> v )
+ None
+ in
+ Option.map Css_lib.Merge.extract_css merge_result
module AddFile = struct
type t = file
@@ -51,214 +45,163 @@ module AddFile = struct
let _ = state.files##push file in
let elements = state.files##.length
and result_css = build_result state.files in
- { state with elements ; result_css }
+ { state with elements; result_css }
end
module DelFile = struct
-
type t = File.t
let process file state =
- let files = state.files##filter
- (Js.wrap_callback @@ (fun elt _ _ -> Js.bool (elt.file != file))) in
- let elements = files##.length
- and result_css = build_result files in
- { files ; elements ; result_css }
+ let files =
+ state.files##filter
+ (Js.wrap_callback @@ fun elt _ _ -> Js.bool (elt.file != file))
+ in
+ let elements = files##.length and result_css = build_result files in
+ { files; elements; result_css }
end
let header =
+ let button = El.span [ El.txt' "Retirer" ] in
+
+ El.set_inline_style (Jstr.v "float") (Jstr.v "right") button;
+
+ let block = El.div [ El.span [ El.txt' "Fichier" ]; button ] in
+ El.set_inline_style El.Style.display (Jstr.v "block") block;
+ block
+
+let file_list : App.event E.send -> file -> El.t =
+ fun sender f ->
+ let icon =
+ El.i [] ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-check") ]
+ in
+
let button =
- El.span
- [ El.txt' "Retirer" ] in
-
- El.set_inline_style
- (Jstr.v "float")
- (Jstr.v "right")
- button;
-
- let block =
- El.div
- [ El.span [El.txt' "Fichier"]
- ; button ]
+ El.i [] ~at:At.[ class' (Jstr.v "fas"); class' (Jstr.v "fa-times-circle") ]
in
- El.set_inline_style
- (El.Style.display)
- (Jstr.v "block")
- block;
- block
-let file_list
- : App.event E.send -> file -> El.t
- = fun sender f ->
- let icon =
- El.i []
- ~at:At.[ class' (Jstr.v "fas")
- ; class' (Jstr.v "fa-check") ] in
-
- let button =
- El.i []
- ~at:At.[ class' (Jstr.v "fas")
- ; class' (Jstr.v "fa-times-circle") ] in
-
- El.set_inline_style
- (Jstr.v "float")
- (Jstr.v "right")
- button;
-
- Ev.listen
- Ev.click
- (fun _ -> sender (
- App.dispatch (module DelFile) f.file))
- (El.as_target button);
-
- match f.css with
- (* A css exists, add the icon element *)
- | Some _ ->
- El.div
- [ El.txt (File.name f.file)
- ; icon
- ; button ]
-
- | None ->
- El.div
- [ El.txt (File.name f.file)
- ; button ]
-
-
-let buttons:
- state -> El.t -> El.t list
- = fun state input ->
- let b = El.button [ El.txt' "Ajouter un fichier…" ]
- ~at:[ At.class' (Jstr.v "button")] in
-
- let d = El.button [ El.txt' "Télécharger" ]
- ~at:[ At.class' (Jstr.v "button")] in
-
- Ev.listen Ev.click (fun _e -> El.click input) (El.as_target b);
- Ev.listen Ev.click (fun _ ->
-
- match state.result_css with
- | None -> ()
- | Some result ->
- let formatter = Format.str_formatter in
- Css_lib.Print.(css minify_printer formatter result);
- let content = Format.flush_str_formatter () in
- Elements.Transfert.send
- ~mime_type:(Jstr.v "text/css")
- ~filename:(Jstr.v "result.css")
- (Jstr.v content)
- )
- (El.as_target d);
-
- let has_css = state.files##some
- (Js.wrap_callback (fun elem _idx _arr -> Js.bool (elem.css != None))) in
-
- match Js.to_bool has_css with
- | true -> [b; d]
- | false -> [b]
+ El.set_inline_style (Jstr.v "float") (Jstr.v "right") button;
-let display_content css =
+ ignore
+ @@ Ev.listen Ev.click
+ (fun _ -> sender (App.dispatch (module DelFile) f.file))
+ (El.as_target button);
+ match f.css with
+ (* A css exists, add the icon element *)
+ | Some _ -> El.div [ El.txt (File.name f.file); icon; button ]
+ | None -> El.div [ El.txt (File.name f.file); button ]
+
+let buttons : state -> El.t -> El.t list =
+ fun state input ->
+ let b =
+ El.button
+ [ El.txt' "Ajouter un fichier…" ]
+ ~at:[ At.class' (Jstr.v "button") ]
+ in
+
+ let d =
+ El.button [ El.txt' "Télécharger" ] ~at:[ At.class' (Jstr.v "button") ]
+ in
+
+ ignore @@ Ev.listen Ev.click (fun _e -> El.click input) (El.as_target b);
+ ignore
+ @@ Ev.listen Ev.click
+ (fun _ ->
+ ignore
+ @@
+ match state.result_css with
+ | None -> ()
+ | Some result ->
+ let formatter = Format.str_formatter in
+ Css_lib.Print.(css minify_printer formatter result);
+ let content = Format.flush_str_formatter () in
+ Elements.Transfert.send ~mime_type:(Jstr.v "text/css")
+ ~filename:(Jstr.v "result.css") (Jstr.v content))
+ (El.as_target d);
+
+ let has_css =
+ state.files##some
+ (Js.wrap_callback (fun elem _idx _arr -> Js.bool (elem.css != None)))
+ in
+
+ match Js.to_bool has_css with
+ | true -> [ b; d ]
+ | false -> [ b ]
+
+let display_content css =
match css with
| None -> []
| Some result ->
- let formatter = Format.str_formatter in
- Css_lib.Print.(css pretty_printer formatter result);
- let content = Format.flush_str_formatter () in
+ let formatter = Format.str_formatter in
+ Css_lib.Print.(css pretty_printer formatter result);
+ let content = Format.flush_str_formatter () in
- let area =
- El.textarea
- [ El.txt' content ] in
+ let area = El.textarea [ El.txt' content ] in
- El.set_inline_style
- (Jstr.v "width")
- (Jstr.v "100%")
- area;
+ El.set_inline_style (Jstr.v "width") (Jstr.v "100%") area;
- El.set_inline_style
- (Jstr.v "height")
- (Jstr.v "200px")
- area;
+ El.set_inline_style (Jstr.v "height") (Jstr.v "200px") area;
- El.set_inline_style
- (Jstr.v "max-height")
- (Jstr.v "50vh")
- area;
+ El.set_inline_style (Jstr.v "max-height") (Jstr.v "50vh") area;
- El.set_inline_style
- (Jstr.v "resize")
- (Jstr.v "none")
- area;
+ El.set_inline_style (Jstr.v "resize") (Jstr.v "none") area;
- [ El.h2 [ El.txt' "Prévisualisation"]
- ; area ]
+ [ El.h2 [ El.txt' "Prévisualisation" ]; area ]
let main id =
-
- match (Jv.is_none id) with
- | true -> Console.(error [str "No element with id '%s' found"; id])
+ match Jv.is_none id with
+ | true -> Console.(error [ str "No element with id '%s' found"; id ])
| false ->
- let elements = El.div [] in
-
- let del_file_event, del_file_sender = Note.E.create () in
-
- let input, file_event = Elements.Input.file_loader
- (Jstr.v "css") in
-
- let add_file_event =
- Note.E.map
- (fun Elements.Input.{file ; content} ->
- let str_content = Jstr.to_string content in
- let css = try
- Some (Css.Parser.parse_stylesheet str_content)
- with
- | _ -> None
- in
- App.dispatch (module AddFile) { file ; css})
- file_event in
-
- let state =
- App.run
- init
- (E.select
- [ add_file_event
- ; del_file_event
- ])
- in
-
- (* For each file, add a delete button *)
- let _ = Elr.def_children
- elements
- (S.map (fun state ->
- let elements =
- Jv.to_list
- (fun x -> file_list del_file_sender (Jv.Id.of_jv x))
- (Jv.Id.to_jv state.files) in
- match elements with
- | [] -> display_content state.result_css
- | _ ->
- List.append
- (header::elements)
- (display_content state.result_css))
- state) in
-
- let header = El.span [] in
-
- (* The input is hidden, it will be activated by a button *)
- El.set_inline_style El.Style.display (Jstr.v "none") input;
-
- Elr.def_children
- header
- (S.map (fun state ->
- input::(buttons state input))
- state);
-
- El.set_children (Jv.Id.of_jv id) [El.p [header]; elements]
+ let elements = El.div [] in
+
+ let del_file_event, del_file_sender = Note.E.create () in
+
+ let input, file_event = Elements.Input.file_loader (Jstr.v "css") in
+
+ let add_file_event =
+ Note.E.map
+ (fun Elements.Input.{ file; content } ->
+ let str_content = Jstr.to_string content in
+ let css =
+ try Some (Css.Parser.parse_stylesheet str_content) with
+ | _ -> None
+ in
+ App.dispatch (module AddFile) { file; css })
+ file_event
+ in
+
+ let state = App.run init (E.select [ add_file_event; del_file_event ]) in
+
+ (* For each file, add a delete button *)
+ let _ =
+ Elr.def_children elements
+ (S.map
+ (fun state ->
+ let elements =
+ Jv.to_list
+ (fun x -> file_list del_file_sender (Jv.Id.of_jv x))
+ (Jv.Id.to_jv state.files)
+ in
+ match elements with
+ | [] -> display_content state.result_css
+ | _ ->
+ List.append (header :: elements)
+ (display_content state.result_css))
+ state)
+ in
+
+ let header = El.span [] in
+
+ (* The input is hidden, it will be activated by a button *)
+ El.set_inline_style El.Style.display (Jstr.v "none") input;
+
+ Elr.def_children header
+ (S.map (fun state -> input :: buttons state input) state);
+
+ El.set_children (Jv.Id.of_jv id) [ El.p [ header ]; elements ]
let () =
-
let open Jv in
- let main = obj
- [| "attach", (repr main) |] in
+ let main = obj [| ("attach", repr main) |] in
set global "merger" main
diff --git a/lib/application/dune b/lib/application/dune
index 63f2baa..f403b24 100755
--- a/lib/application/dune
+++ b/lib/application/dune
@@ -2,6 +2,7 @@
(name application)
(libraries
brr
+ note
brr.note
)
)
diff --git a/viz.js/process/formatter.ml b/viz.js/process/formatter.ml
index e6a8a0e..057ec25 100755
--- a/viz.js/process/formatter.ml
+++ b/viz.js/process/formatter.ml
@@ -1,100 +1,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 = begin function
+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"
-end
-let rec print_links (acc:Js.js_string Js.t) = begin function
+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
-end
+ | (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 shape =
+ Printer.inject
+ "[label=<<TABLE BORDER=\"0\" CELLBORDER=\"1\" CELLSPACING=\"0\">"
-let rec parse lexbuf acc current_name level links = begin
+let rec parse lexbuf acc current_name level links =
try
- begin match Tab_Lexer.parse_line lexbuf with
- | Root content ->
- let acc' = Printer.print2 acc
- content
- shape
- in
+ 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) ->
+ | 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
+ 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
+ let links' =
+ match target with
| None -> links
- | Some (target, comment, arrow) -> (current_name, level', target, comment, arrow)::links
- end in
+ | 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
+ | Redirection (target, comment, arrow) ->
+ let links' = (current_name, level, target, comment, arrow) :: links in
parse lexbuf acc current_name level links'
- | NewLine ->
+ | NewLine ->
let acc' =
- if (level >= 0) then (
- print_links (acc##concat (Js.string "</TABLE>>];\n")) links;
- ) else (
- acc
- ) in
+ 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
+ | 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
+ with
+ | Tab_Lexer.Eof ->
+ if level >= 0 then
+ let text = Js.string "</TABLE>>];\n" in
+ print_links (acc##concat text) links
+ else acc
- let text = (Js.string "digraph G {rankdir=LR;node [shape=plaintext];") in
+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
+ 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/tab_Lexer.mll b/viz.js/process/tab_Lexer.mll
index 67793e4..5149917 100755
--- a/viz.js/process/tab_Lexer.mll
+++ b/viz.js/process/tab_Lexer.mll
@@ -59,7 +59,7 @@ rule parse_line = shortest
(regular* as comment) newline
{ Entry (Js.string _2, Some (Js.string _target, Js.string comment, (get_arrow _arrow)))}
- | (space+ as _1)
+ | (spaces as _1)
(regular+ as _2) newline
{ Entry (Js.string _2, None) }
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-22 19:37:18 +0000