Source file theme.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

open Misc


include (val Log.create_src "stk.theme")

module P = (val Css.P.mk_prop_space "stk")

type t = {
    name : string ;
    preamble : string Css.css ;
    body : string Css.css ;
  }

let css_from_string ?fname name css =
  let statements =
    try Css.parse_string ~prop_space:(module P) ?fname css
    with e ->
        let msg = Printf.sprintf "[%s]%s%s"
          name
           (match fname with None -> Printf.sprintf "In\n%s\n" css | Some _ -> "")
             (Printexc.to_string e)
        in
        Log.err (fun m -> m "%s" msg);
        []
  in
  [%debug "loaded css in %S: %a" name Css.pp_string_css statements];
  let statements = Css.expand_nested statements in
  statements

let add_css_to_t ?preamble ?body ?fname t =
  let t =
    match preamble with
    | None -> t
    | Some css ->
        let pr = css_from_string ?fname t.name css in
        { t with preamble = t.preamble @ pr }
  in
  let t =
    match body with
    | None -> t
    | Some css ->
        let pr = css_from_string ?fname t.name css in
        { t with body = t.body @ pr }
  in
  t

let get_or_create map name =
  match Smap.find_opt name !map with
  | None ->
      let t = { name ; preamble = []; body = [] } in
      map := Smap.add name t !map;
      t
  | Some t -> t

let themes = ref Smap.empty
let extensions = ref Smap.empty

let get_or_create_theme = get_or_create themes
let get_or_create_extension = get_or_create extensions

let on_theme_update = ref (fun () -> ())

let current_name = "_"
let set_current_theme name =
  let t = get_or_create_theme name in
  (* add extensions *)
  let t = Smap.fold
    (fun _ ext t ->
       { t with
         preamble = t.preamble @ ext.preamble ;
         body = t.body @ ext.body ;
       })
      !extensions t
  in
  themes := Smap.add current_name t !themes;
  !on_theme_update ()

let current_theme () =
  let t = get_or_create_theme current_name in
  t.name, t

let update_current_theme () =
  let (name,_) = current_theme () in
  set_current_theme name

let remove_ map name = map := Smap.remove name !map
let remove_theme = function
| name when name = current_name -> ()
| name -> remove_ themes name

let remove_extension name = remove_ extensions name; update_current_theme ()

let add_css_to_ map ?fname ?preamble ?body name =
  let t = get_or_create map name in
  let t = add_css_to_t ?fname ?preamble ?body t in
  map := Smap.add name t !map

let add_css_to_theme = add_css_to_ themes
let add_css_to_extension ?fname ?preamble ?body name =
  add_css_to_ extensions ?fname ?preamble ?body name ;
  update_current_theme ()

type computed_props = Css.C.t

let statements t = t.preamble @ t.body
let rules t =
  let l = List.fold_left (fun acc s ->
       match s with
       | Css.S.Rule (r,_) -> r :: acc
       | _ -> acc)
    [] (statements t)
  in
  List.rev l

let add_css_file_to_ =
  let f = function
  | None -> Lwt.return_none
  | Some file ->
      let%lwt css = Lwt_io.(with_file ~mode:Input file read) in
      Lwt.return_some (file, css)
  in
  fun map ?preamble ?body name ->
    let%lwt preamble = f preamble in
    let%lwt body = f body in
    Option.iter (fun (fname,s) -> add_css_to_ map ~fname ~preamble:s name) preamble;
    Option.iter (fun (fname,s) -> add_css_to_ map ~fname ~body:s name) body;
    Lwt.return_unit

let add_css_file_to_theme = add_css_file_to_ themes
let add_css_file_to_extension ?preamble ?body name =
  let%lwt () = add_css_file_to_ extensions ?preamble ?body name in
  update_current_theme ();
  Lwt.return_unit

module Vp =
  struct
    open Css.Vp
    open Angstrom
    open Css.U
    let int ctx = (ws ctx *>
       (take_while1 is_digit) >>= fun s -> return (int_of_string s))

    let uchar ctx = int ctx >>| Uchar.of_int

    let color ctx = (ws ctx *>
       peek_char >>= function
     | None -> fail ""
     | Some '#' -> (advance 1 >>= fun () ->
              Css.Vp.hexa_color >>= function `Rgba(r,g,b,a) ->
                  return (Color.of_rgba_0_1 r g b a))
     | Some _ ->
         ident ctx >>= function
         | "transparent",_ -> return Color.transparent
         | "rgb", _ ->
             (lpar ctx *>
              (rgb_args ctx <* rpar ctx >>| fun (r,g,b) -> Color.of_rgba_0_1 r g b 1.) <|>
              (rgba_args ctx <* rpar ctx >>| fun (r,g,b,a) -> Color.of_rgba_0_1 r g b a)
              )
         | "rgba", _ ->
             (lpar ctx *> rgba_args ctx <* rpar ctx >>|
              fun (r,g,b,a) -> Color.of_rgba_0_1 r g b a)
         | ident,_ -> return (Color.of_string ident)
    ) <?> "color"

    let string ctx = Css.Vp.string ctx >>= (fun s -> return s.Css.T.s)

    let bool ctx = (ws ctx *>
       (string_ci "true" >>= fun _ -> return true)
         <|> (string_ci "false" >>= fun _ -> return false)
      ) <?> "bool"

    let opt p ctx = Angstrom.option None (p ctx >>= fun v -> return (Some v))

    let font_family ctx = Css.Vp.string ctx >>= fun qs -> return qs.Css.T.s

    let font_desc ctx = (ws ctx *>
       font_family ctx >>= fun family ->
         opt int ctx >>= fun size ->
           opt bool ctx >>= fun italic ->
           opt bool ctx >>= fun bold ->
           opt bool ctx >>= fun underline ->
           opt bool ctx >>= fun strikethrough ->
           opt bool ctx >>= fun kerning ->
           opt int ctx >>= fun outline ->
           return (Font.font_desc ?size ?italic ?bold ?underline
            ?strikethrough ?kerning ?outline family)
      ) <?> "font_desc"

    let explicit_opt p ctx = (ws ctx *>
      (string_ci "none" >>= fun _ -> return None)
         <|> (p ctx >>= fun v -> return (Some v))
      )
    let list p ctx = Angstrom.many (p ctx)
  end

let string_of_option to_string = function
| None -> ""
| Some v -> to_string v

let string_of_option_explicit to_string = function
| None -> "none"
| Some v -> to_string v

let string_of_list to_string list =
  String.concat " " (List.map to_string list)

let string_of_bool b = if b then "true" else "false"
let string_of_color c = Color.to_string c

let string_of_font_desc d =
  Printf.sprintf "%S %d %b %b %b %b %b %d"
    d.Font.family d.size d.italic d.bold d.underline
    d.strikethrough d.kerning d.outline

let setters : (Props.t -> computed_props -> unit) list ref = ref []
let add_setter css_p f =
  let setter props c =
    match Css.C.opt c css_p with
    | None -> ()
    | Some v -> f props v
  in
  setters := setter :: !setters

let add_direct_setter css_p p =
  add_setter css_p (fun props v -> Props.set props p v)

let p_default prop d = Option.value ~default:d (Props.default_value prop)
let p_side_default p d side =
  match Props.default_value p with
  | None -> d
  | Some t ->
      match side with
      | `Top -> t.Props.top
      | `Right -> t.right
      | `Bottom -> t.bottom
      | `Left -> t.left

let mk_trbl_top_setter p (props:Props.t) v =
  let t = Props.get props p in
  let t = { t with Props.top = v } in
  Props.set props p t
let mk_trbl_right_setter p (props:Props.t) v =
  let t = Props.get props p in
  let t = { t with Props.right = v } in
  Props.set props p t
let mk_trbl_bottom_setter p (props:Props.t) v =
  let t = Props.get props p in
  let t = { t with Props.bottom = v } in
  Props.set props p t
let mk_trbl_left_setter p (props:Props.t) v =
  let t = Props.get props p in
  let t = { t with Props.left = v } in
  Props.set props p t

let mk_trbl_props : 'a -> 'a Props.trbl Props.prop -> ?inherited:bool ->
  ('a -> string) -> (Css.T.ctx -> 'a Angstrom.t) ->
    ('a Css.P.prop * 'a Css.P.prop * 'a Css.P.prop * 'a Css.P.prop) =
    fun default p ?(inherited=Props.inherited p) to_string parser ->
      let mk side =
        let def = p_side_default p default side in
        let side = Css.T.string_of_side side in
        P.mk_prop (Printf.sprintf "%s_%s" Props.(name p) side)
          ~inherited def to_string parser
      in
      let (top,right,bottom,left) as props = (mk `Top, mk `Right, mk `Bottom, mk `Left) in
      add_setter top (mk_trbl_top_setter p);
      add_setter right (mk_trbl_right_setter p);
      add_setter bottom (mk_trbl_bottom_setter p);
      add_setter left (mk_trbl_left_setter p);
      Css.C.(register_prop_fun top map);
      Css.C.(register_prop_fun right map);
      Css.C.(register_prop_fun bottom map);
      Css.C.(register_prop_fun left map);
      let shorthand = Css.Sh.trbl props parser in
      let () = Css.Sh.register_shorthand (module P) Props.(name p) shorthand in
      props

let (padding_top, padding_right, padding_bottom, padding_left) as paddings =
  mk_trbl_props 0 Props.padding string_of_int Vp.int

let (margin_top, margin_right, margin_bottom, margin_left) as margins =
  mk_trbl_props 0 Props.margin string_of_int Vp.int

let (border_width_top, border_width_right, border_width_bottom, border_width_left) as border_widths =
  mk_trbl_props 0 Props.border_width string_of_int Vp.int

let (border_color_top, border_color_right, border_color_bottom, border_color_left) as border_colors =
  mk_trbl_props Color.transparent Props.border_color Color.to_string Vp.color

let (border_color_hover_top, border_color_hover_right,
   border_color_hover_bottom, border_color_hover_left) as border_color_hovers =
  mk_trbl_props Color.transparent Props.border_color_hover Color.to_string Vp.color

let (border_color_selected_top, border_color_selected_right,
   border_color_selected_bottom, border_color_selected_left) as border_color_selecteds =
  mk_trbl_props Color.transparent Props.border_color_selected Color.to_string Vp.color

let (border_color_focused_top, border_color_focused_right,
   border_color_focused_bottom, border_color_focused_left) as border_color_focuseds =
  mk_trbl_props Color.transparent Props.border_color_focused Color.to_string Vp.color

let mk_prop to_string parser default =
  fun ?inherited ?(def=default) p ->
    let inherited = Option.value ~default:(Props.inherited p) inherited in
    let def = p_default p def in
    let css_p = P.mk_prop Props.(name p) ~inherited def to_string parser in
    add_direct_setter css_p p;
    Css.C.(register_prop_fun css_p map);
    css_p

let int_prop = mk_prop string_of_int Vp.int 0
let uchar_prop = mk_prop (fun uc -> string_of_int (Uchar.to_int uc)) Vp.uchar (Uchar.of_int 0)
let float_prop = mk_prop string_of_float Css.Vp.number 0.
let color_prop = mk_prop Color.to_string Vp.color Color.transparent
let bool_prop = mk_prop string_of_bool Vp.bool true
let string_prop = mk_prop (fun s -> Printf.sprintf "%S" s) Vp.string ""
let font_desc_prop = mk_prop string_of_font_desc Vp.font_desc Font.default_font_desc

let keystate_list_prop = mk_prop
  (string_of_list Key.string_of_keystate)
    (Vp.list Key.css_keystate_parser) []

let keyword_prop to_string opt_of_string default =
  let parser ctx =
    let open Angstrom in
    Css.Vp.ident ctx >>= fun (i,loc) ->
      match opt_of_string i with
      | None -> fail (Printf.sprintf "Unknown keyword %S" i)
      | Some v -> return v
  in
  mk_prop to_string parser default

let mk_font_prop name to_string parser setter def =
  let name = Printf.sprintf "font_%s" name in
  let css_p = P.mk_prop name ~inherited:true def to_string parser in
  let setter p v =
    (*Log.warn (fun m -> m "Setting prop from css prop %S (v=%s)" name (to_string v));*)
    setter p v;
    (*Log.warn (fun m -> m "props => %a" Props.pp p);*)
  in
  add_setter css_p setter;
  Css.C.(register_prop_fun css_p map);
  css_p

let hexpand = int_prop Props.hexpand
let vexpand = int_prop Props.vexpand
let visible = bool_prop Props.visible
let sensitive = bool_prop Props.sensitive
let insensitive_color_mask = color_prop Props.insensitive_color_mask
let hfill = bool_prop Props.hfill
let vfill = bool_prop Props.hfill
let halign = float_prop Props.halign
let valign = float_prop Props.valign
let width = int_prop Props.width
let height = int_prop Props.height
let max_width = int_prop Props.max_width
let max_height = int_prop Props.max_height
let fill = bool_prop Props.fill
let bg_fill_borders = bool_prop Props.bg_fill_borders

let font_family = mk_font_prop "family" (fun s -> s) Vp.font_family
  Props.set_font_family Font.default_font_desc.family
let font_size = mk_font_prop "size" string_of_int Vp.int
  Props.set_font_size Font.default_font_desc.size
let font_underline = mk_font_prop "underline" string_of_bool Vp.bool
  Props.set_font_underline Font.default_font_desc.underline
let font_strikethrough = mk_font_prop "strikethrough" string_of_bool Vp.bool
  Props.set_font_strikethrough Font.default_font_desc.strikethrough
let font_kerning = mk_font_prop "kerning" string_of_bool Vp.bool
  Props.set_font_kerning Font.default_font_desc.kerning
let font_outline = mk_font_prop "outline" string_of_int Vp.int
  Props.set_font_outline Font.default_font_desc.outline

let bold = bool_prop Props.bold
let italic = bool_prop Props.italic

let fg_color = color_prop Props.fg_color
let fg_color_hover = color_prop Props.fg_color_hover
let fg_color_selected = color_prop Props.fg_color_selected
let fg_color_focused = color_prop Props.fg_color_focused

let bg_color = color_prop Props.bg_color
let bg_color_hover = color_prop Props.bg_color_hover
let bg_color_selected = color_prop Props.bg_color_selected
let bg_color_focused = color_prop Props.bg_color_focused

let selection_fg_color = color_prop Props.selection_fg_color
let selection_bg_color = color_prop Props.selection_bg_color

let input_ghost_color = color_prop Props.input_ghost_color
let input_bg_color = color_prop Props.input_bg_color

let current_line_bg_color = color_prop Props.current_line_bg_color

let click_mask = color_prop Props.click_mask

let focusable = bool_prop Props.focusable
let can_focus = bool_prop Props.can_focus
let show_on_focus = bool_prop Props.show_on_focus

let editable = bool_prop Props.editable

let cursor_width = int_prop Props.cursor_width
let cursor_color = color_prop Props.cursor_color
let active_cursor_color = color_prop Props.active_cursor_color

let scrollbar_width = int_prop Props.scrollbar_width
let scrollbar_handle_min_size = int_prop Props.scrollbar_handle_min_size
let scrollbar_handle_color = color_prop Props.scrollbar_handle_color
let scrollbar_bg_color = color_prop Props.scrollbar_bg_color

let default_theme_preamble =
  match Sys.getenv_opt "STK_DEFAULT_THEME_PREAMBLE" with
  | None | Some "" -> [%blob "themes/default.css"]
  | Some file -> Lwt_main.run Lwt_io.(with_file ~mode:Input file read)

let default_theme_body =
 match Sys.getenv_opt "STK_DEFAULT_THEME_BODY" with
  | None | Some "" -> [%blob "default_theme_body.css"]
  | Some file -> Lwt_main.run Lwt_io.(with_file ~mode:Input file read)

let init on_update =
  (* must be done in init() because css properties must have been defined
     before.*)
  let themes =
    [
      "default", default_theme_preamble ;
      "blue", [%blob "themes/blue.css"] ;
    ]
  in
  List.iter (fun (name, preamble) ->
     add_css_to_theme name ~preamble ~body:default_theme_body)
    themes;
  on_theme_update := on_update ;
  set_current_theme "default";
  (*
     let (name, t) = current_theme () in
     Log.warn (fun m -> m "Theme.init: current_theme=%s\n%a" name
     Css.pp_string_css (statements t))*)
  ()

type path = (string * string Smap.t * string option) list
let string_of_atts atts =
  String.concat "; "
    (List.map (fun (att, v) -> Printf.sprintf "%s=%S" att v) (Smap.bindings atts))

let string_of_path p =
  String.concat ","
    (List.map (fun (w,atts,name) ->
        Printf.sprintf "%s%s%s" w
          (match name with None -> "" | Some s -> "#"^s)
          (if Smap.is_empty atts then ""
           else Printf.sprintf "[%s]" (string_of_atts atts))
     )
     p)
let pp_path ppf p = Format.pp_print_string ppf (string_of_path p)

let attr_value_matches attr v (_,atts,name) =
  let str = match attr with
    | "name" -> name
    | str -> Smap.find_opt str atts
  in
  match str with
  | None -> false
  | Some s ->
      let (s,vs) =
        if v.Css.S.case_sensitive then
          (s, v.v)
        else
          (String.lowercase_ascii s, String.lowercase_ascii v.v)
      in
      match v.op with
      | Exact -> s = vs
      | Exact_list -> List.mem vs (Misc.split_string s [' ';'\n';'\t';'\r'])
      | Hyphen -> s = vs || Misc.is_prefix ~s ~pref:(vs^"-")
      | Prefix -> Misc.is_prefix ~s ~pref:vs
      | Suffix -> Misc.is_suffix ~s ~suff:vs
      | Contain -> Misc.string_contains ~s ~pat:vs


let attr_selector_matches s ((_widget,atts,name) as node) =
  match s with
  | Css.S.Attr_present (_,"name") -> name <> None
  | Attr_present (_,attr) -> Smap.find_opt attr atts <> None
  | Attr_value ((_,attr), v) -> attr_value_matches attr v node

let attr_selectors_match l node =
  List.for_all (fun (s,_) -> attr_selector_matches s node) l

let single_selector_matches s = function
| [] -> false
| ((widget,atts,name) as node) :: _ ->
    (*Log.warn(fun m -> m "selector qname=%s"
       (match s.Css.S.sel_qname with
        | None -> "None"
        | Some ((s1, s2),_) -> Printf.sprintf "Some (%s,%s)" s1 s2));*)
    (match s.Css.S.sel_qname with
     | None -> true
     | Some ((_,("*"|"")),_loc) -> true
     | Some ((_,s),_loc) -> s = widget
    )
    && (attr_selectors_match s.sel_attr node)
    &&
    (match s.sel_id with
     | None -> true
     | Some (id,_) ->
         match name with
         | None -> false
         | Some s -> s = id
    )
let rec selector_matches sel path =
  let open Css.S in
  match sel with
  | Single s -> single_selector_matches s path
  | Inside (s, ss) ->
      (match path with
       | [] | [_] -> false
       | _ :: q ->
           single_selector_matches ss path
             && path_matches_inside s q
      )
  | Child (s, ss) ->
      (match path with
       | [] | [_] -> false
       | _ :: q ->
           single_selector_matches ss path
             && path_matches_child s q
      )
  | Adjacent (s, ss) ->
      Log.warn (fun m -> m "CSS selector 'adjacent' is not supported");
      false

  | Sibling (s, ss) ->
      Log.warn (fun m -> m "CSS selector 'sibling' is not supported");
      false

and path_matches_inside sel path =
      let b =
        match path with
        | [] -> false
        | h :: q ->
            selector_matches sel path
              || path_matches_inside sel q
      in
      (*prerr_endline (Printf.sprintf "path_match_INSIDE path=%s: %b" (string_of_path path) b) ;*)
      b

and path_matches_child sel path =
  (*prerr_endline (Printf.sprintf "path_match_CHILD path=%s" (string_of_path path)) ;*)
  selector_matches sel path

let to_props c =
  let props = Props.empty () in
  List.iter (fun f -> f props c) !setters;
  props

let themes () = List.filter_map
  (fun (name, _) -> if name = current_name then None else Some name)
    (Smap.bindings !themes)
let extensions () = List.map fst (Smap.bindings !extensions)