path: root/css/merger.ml

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
  ; css : Css.Types.Stylesheet.t option
  }

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 AddFile = struct
  type t = file

  let process file state =
    let _ = state.files##push file in
    let elements = state.files##.length
    and result_css = build_result state.files in
    { 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 }
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.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]

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 area =
      El.textarea
        [  El.txt' content ]   in

    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 "max-height")
      (Jstr.v "50vh")
      area;

    El.set_inline_style
      (Jstr.v "resize")
      (Jstr.v "none")
      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])
  | 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 () =

  let open Jv in
  let main = obj
      [| "attach", (repr main) |] in

  set global "merger" main