Source file props.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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Stk properties from CSS properties. *)

let of_css_length = function
| (n,`px) -> Some (truncate n)
| _ -> None

let get_css_length props p =
  match Css.(C.get props p) with
  | `Length x -> of_css_length x
  | _ -> None

let color_of_system_color = ref (function _ -> Stk.Color.black)
let color_of_css p prop =
  match Css.C.get p prop with
  | `Rgba (r,g,b,a) -> Stk.Color.of_rgba_0_1 r g b a
  | `Named_color str -> Stk.Color.of_string str
  | `System_color c -> !color_of_system_color c
  | `Transparent -> Stk.Color.transparent
  | _ -> Stk.Color.black

let fg_color_of_css p = color_of_css p Css.P.color
let bg_color_of_css p = color_of_css p Css.P.background_color

let font_bold_of_css p = match Css.(C.get p P.font_weight) with
  | `Weight n -> n >= 700
  | `Bold -> true
  | _ ->  false
let font_family_of_generic = ref (function
   | `Monospace | `Ui_monospace -> "DejaVu Sans Mono"
   | `Math -> "DejaVu Serif"
   | `Cursive | `Emoji | `Fantasy |`Fangsong
   | `Sans_serif | `Serif | `System_ui
   | `Ui_rounded | `Ui_sans_serif | `Ui_serif -> "Liberation Sans")
let font_family_map = ref (fun name ->
     match String.lowercase_ascii name with
     | "courier" -> "DejaVu Sans Mono"
     | "computer modern" -> "DejaVu Serif"
     | _ -> name
  )
let font_family_of_css =
  let rec iter = function
  | `Family name :: q ->
      let name2 = !font_family_map name in
      if name <> name2 then
        Log.info (fun m -> m "mapping font %S to %S" name name2);
      if Stk.Font.family_is_available name2 then name2 else iter q
  | `Generic g :: _ -> !font_family_of_generic g
  | _ -> "Liberation Sans"
  in
  fun p -> iter Css.(C.get p P.font_family)

let font_italic_of_css p = Css.(C.get p P.font_style) = `Italic
let font_kerning_of_css p = match Css.(C.get p P.font_kerning) with
  | `Auto|`Normal -> true
  | `None -> false

let font_size_of_css p =
  match get_css_length p Css.P.font_size with
  | Some n -> n
  | _ -> 12

let font_desc_of_css_props p =
  let size = font_size_of_css p in
  let italic = font_italic_of_css p in
  let bold = font_bold_of_css p in
  let underline = false in
  let strikethrough = false in
  let kerning = font_kerning_of_css p in
  let outline = 0 in
  let family = font_family_of_css p in
  Stk.Font.font_desc ~size ~italic ~bold ~underline ~strikethrough
    ~kerning ~outline family

let max_abs_width_of_css p = get_css_length p Css.P.max_width

let border_widths_of_css =
  let f p prop =
    match get_css_length p prop with
    | Some n -> n
    | None -> 0
  in
  fun p ->
    Stk.Props.trbl
      ~top:(f p Css.P.border_top_width)
      ~right:(f p Css.P.border_right_width)
      ~bottom:(f p Css.P.border_bottom_width)
      ~left:(f p Css.P.border_left_width)

let has_border p (prop : (Css.T.line_style Css.P.prop)) =
  match Css.C.get p prop with
  | `None | `Hidden -> false
  | _ -> true

let border_colors_of_css =
  let f p s c =
    if has_border p s
    then color_of_css p c
    else Stk.Color.transparent
  in
  fun p ->
    Stk.Props.trbl
      ~top:Css.P.(f p border_top_style border_top_color)
      ~right:Css.P.(f p  border_right_style border_right_color)
      ~bottom:Css.P.(f p border_bottom_style border_bottom_color)
      ~left:Css.P.(f p border_left_style border_left_color)

let margins_of_css =
  let f p prop = match get_css_length p prop with
    | Some n -> n
    | None -> 0
  in
  fun p ->
    Stk.Props.trbl
      ~top:(f p Css.P.margin_top)
      ~right:(f p Css.P.margin_right)
      ~bottom:(f p Css.P.margin_bottom)
      ~left:(f p Css.P.margin_left)

let paddings_of_css =
  let f p prop = match get_css_length p prop with
    | Some n -> n
    | None -> 0
  in
  fun p ->
    Stk.Props.trbl
      ~top:(f p Css.P.padding_top)
      ~right:(f p Css.P.padding_right)
      ~bottom:(f p Css.P.padding_bottom)
      ~left:(f p Css.P.padding_left)

let text_valign_of_css p =
  match Css.(C.get p P.vertical_align) with
  | `Baseline -> Stk.Props.Baseline
  | `Sub -> Sub
  | `Super -> Super
  | `Top -> Top
  | `Text_top -> Text_top
  | `Middle -> Middle
  | `Bottom -> Bottom
  | `Text_bottom -> Text_bottom
  | x ->
      Log.warn (fun m -> m "text_valign: css value not handled: %a"
         Css.T.pp_vertical_align x);
      Baseline

let props_of_css_props props =
  let module P = Stk.Props in
  let p = P.create () in

  P.(set p font_desc (font_desc_of_css_props props));

  P.(set p fg_color (fg_color_of_css props));

  let bg_color =
    match bg_color_of_css props with
    | c when c = Stk.Color.transparent -> None
        (* use this to see all background rects: (Int32.of_string "0xaa000011")*)
    | x -> Some x
  in
  (match bg_color with
   | None ->
       P.(set p fill false);
   | Some col ->
       P.(set p fill true);
       P.(set p bg_fill_borders true);
       P.(set p bg_color col)
  );

  let text_valign = text_valign_of_css props in
  P.(set p text_valign) text_valign;
  let margins = margins_of_css props in
  P.(set p margin) margins;

  let paddings = paddings_of_css props in
  P.(set p padding) paddings;
  let collapse_spaces, wrap_on_break, wrap =
    match Css.(C.get props P.white_space) with
    | `Normal -> (true, false, true)
    | `Nowrap -> (true, false, false)
    | `Pre -> (false, true, false)
    | `Pre_line -> (true, true, true)
    | `Pre_wrap
    | `Break_spaces -> (false, true, true)
  in
  P.(set p Stk.Flex.collapse_spaces) collapse_spaces;
  P.(set p Stk.Flex.wrap_on_break) wrap_on_break ;
  P.(set p Stk.Flex.wrap) wrap;

  let justification =
    match Css.(C.get props P.text_align) with
    | `Start | `Left -> `Start
    | `End | `Right -> `End
    | `Center -> `Center
    | `Justify | `Justify_all  ->
        if collapse_spaces then `Justified else `Start
    | x ->
       Log.warn (fun m -> m "text-align value not computed: %a"
           Css.T.pp_text_align x);
       `Start
  in
  P.(set p Stk.Flex.justification) justification;
  let items_alignment = `Baseline in
  P.(set p Stk.Flex.items_alignment) items_alignment ;
  P.(set p visible) (Css.(C.get props P.display) <> `None);

  let opa =
    let f = match Css.(C.get props P.opacity) with
      | `Factor f -> f
      | `Percent p -> p /. 100.
    in
    if f < 1. then Some (max 0. f) else None
  in
  P.(set_opt p opacity opa);

  (match Css.(C.get props P.border_collapse) with
   | `Collapse ->
       P.set p Stk.Table.row_inter_padding 0;
       P.set p Stk.Table.column_inter_padding 0;
   | `Separate ->
       let (x,y) = Css.(C.get props P.border_spacing) in
       let x = of_css_length x in
       let y = of_css_length y in
       Option.iter (P.set p Stk.Table.row_inter_padding) y;
       Option.iter (P.set p Stk.Table.column_inter_padding) x;
  );
  p