Source file c.ml

(*********************************************************************************)
(*                OCaml-CSS                                                      *)
(*                                                                               *)
(*    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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Computing values. *)

open T
open P

(** {2 Mapping properties to values} *)

(** A {!Computed.t} maps a ['a] property to a value of type ['a], if any. *)
module Computed =
  struct
    type binding = B : 'a prop * 'a -> binding
    type t = binding P.M.t
    let compare : t -> t -> int = P.M.compare (fun _ _ -> 0)
    let empty = P.M.empty
    let add t p v = P.M.add p (B (p, v)) t
    let opt  : type a. t -> a prop -> a option = fun t p ->
      match P.M.find_opt p t with
      | None -> None
      | Some (B (p2,v)) ->
          match P.eq (P.tid p) (P.tid p2) with
          | Some P.Teq -> Some v
          | _ -> None
    let get t p = match opt t p with
      | None -> P.initial p
      | Some v -> v
    let pp ppf t = P.M.iter
      (fun _ (B(p,v)) -> Format.fprintf ppf "%s: %a@." (P.name p) (P.pp p) v) t
    let to_string t =
      let b = Buffer.create 256 in
      P.M.iter
        (fun _ (B(p,v)) -> Printf.bprintf b "%s: %s\n" (P.name p) (P.to_string p v)) t;
      Buffer.contents b
  end

type t = Computed.t

(** [opt t p] returns the computed value of [p] in [t], if any. *)
let opt : t -> 'a prop -> 'a option = Computed.opt

(** [opt t p] returns the computed value of [p] in [t] if present
  or else returns the initial value of [p]. *)
let get : t -> 'a prop -> 'a = Computed.get

(** [add t p v] adds binding from [p] to [v] in [t]. *)
let add : t -> 'a prop -> 'a -> t = Computed.add

(** [filter_inherited t] returns bindings of [t] where the property
  is inherited. *)
let filter_inherited : t -> t = P.filter (fun (Computed.B (p,_)) -> P.inherited p)

let empty : t = Computed.empty
let pp : Format.formatter -> t -> unit = Computed.pp
let to_string : t -> string = Computed.to_string

(** [comp_global ~parent p v] returns value of [p] according
  to global value [v], i.e. it returns the initial value of [p],
  of the value of [p] in [parent]. *)
let comp_global : parent:t -> 'a prop -> T.global_kw -> 'a =
  fun ~parent p -> function
| `Initial -> P.initial p
| `Inherit -> get parent p
| `Revert when P.inherited p -> get parent p
| `Revert -> P.initial p
| `Unset when P.inherited p -> get parent p
| `Unset -> P.initial p
| `Revert_layer when P.inherited p -> get parent p
| `Revert_layer -> P.initial p

(** [get_p ~parent t p] returns value of [p] in [t].
  If [p] is not mapped in [t] and [p] is not inherited, returns initial value of [p].
  If [p] is inherited, returns its value in [parent].
  If [p] is not mapped in [parent], returns initial value of [p].*)
let get_p : parent:t -> t -> 'a prop -> 'a = fun ~parent t p ->
  match opt t p with
  | Some v -> v
  | None when not (P.inherited p) -> P.initial p
  | None ->
      match opt parent p with
      | None -> P.initial p
      | Some x -> x

(**/**)

let expand : (module P.Prop_space) -> 'a P.value_parser -> t -> string -> string option -> 'a option =
  let parse_string parser str =
    let ctx = string_ctx str in
    let start = T.(pos_of_string_at str 0) in
    let parser = parser ctx ~start in
    (*Log.warn (fun m -> m "C.expand: %S" str);*)
    (* FIXME ? don't know why consume:All does not work *)
    match Angstrom.parse_string ~consume:Angstrom.Consume.Prefix parser str with
    | Ok v -> v
    | Error msg -> U.fail_at ctx (Other (Printf.sprintf "%S: %s" str msg))
  in
  fun props ->
    let module Space = (val props : P.Prop_space) in
    let rec expand parser t seen var default =
      (*Log.warn (fun m -> m "Expanding %S with prop %S" var (P.name p));*)
      match Space.get_var_prop var with
      | None ->
          (*prerr_endline (Printf.sprintf "could not get pvar %s in Props" var);*)
          None
      | Some pvar ->
          let str = opt t pvar in
          match str with
          | None ->
              (*prerr_endline (Printf.sprintf "[%s]var %s has no value"
               Space.space_name (P.name pvar));*)
              None
          | Some str ->
              (*prerr_endline (Printf.sprintf "var %s has string value %S" (P.name pvar) str);*)
              let v = parse_string parser str in
              match v.v with
              | `Var (id, default) when not (T.Sset.mem id seen) ->
                  expand parser t (T.Sset.add var seen) id default
              | `V v -> Some v
              | _ ->
                  (*prerr_endline (Printf.sprintf "parsed value of %s: %s" (P.name pvar) str);*)
                  None
    in
    fun parser (t:t) name default ->
      expand parser t T.Sset.empty name default

(**/**)

(** {2 Computing functions} *)

let mk_value_parser parser ctx ~start =
  let open Angstrom in
  (parser ctx) >>= fun v ->
    ctx.T.get_pos >>=
    fun stop ->
      let loc = (start, stop) in
      return { v = `V v; loc; important = false }

let or_var props parser f ~root ~parent t default =
  function
  | `V v -> `V (f props ~root ~parent t v)
  | `Var (var_name,var_default) ->
      match expand props (mk_value_parser parser) t var_name var_default with
      | Some v -> `V (f props ~root ~parent t v)
      | None -> `V default

let to_px : T.number -> T.abs_length_unit -> float = fun n -> function
| `In -> n *. 96.
| `px -> n
| `pt -> n *. 96. /. 72. (* 1pt = 1in/72 *)
| `cm -> n *. 96. /. 2.54
| `mm -> n *. 96. /. 25.4
| `q -> (n *. 96. /. 2.54) /. 40.
| `pc -> n *. 96. /. 6.

let px_of_font_size_kw =
  let base = 16. in
  ref (function
   | `Medium -> base
   | `Math -> base
   | `Large -> base *. 1.4
   | `X_large -> base *. 1.6
   | `Xx_large -> base *. 1.6
   | `Xxx_large -> base *. 2.
   | `Small -> base *. 0.8
   | `X_small -> base *. 0.6
   | `Xx_small -> base *. 0.4
   | _ -> Log.warn (fun m -> m "invalid value for C.px_of_font_size"); base
  )

let color props ~root ~parent t v =
  match v with
  | `Current_color -> get parent P.color
  | _ -> v

let accent_color props ~root ~parent t = function
| `Auto -> `Auto
| #T.color as c -> (color props ~root ~parent t c :>T.accent_color)

let length_of_font_size t n u =
  let np =
    match get t P.font_size with
    | `Length (np, (#T.abs_length_unit as up)) -> Some (to_px np up)
    | #T.font_size_kw as x -> Some (!px_of_font_size_kw x)
    | _ -> None
  in
  match np with
  | None ->
      (*err (fun m -> m "length_of_font_size: np=None. t=@.%a"
        pp t
      );*)
      None
  | Some np ->
      match u with
      | `rem | `em -> Some (n *. np)
      | `ex -> Some (n *. 0.5 *. np)
      | _ -> None

let length props ~root ~parent t (n, unit) =
  let npx =
    match unit with
    | #T.abs_length_unit as u -> Some (to_px n u)
    | (`em | `ex) as u -> length_of_font_size t n u
    | `rem as u -> length_of_font_size root n u
    | _ ->
        (* do not perform any other computation *)
        None
  in
  match npx with
  | None -> (n, unit)
  | Some n -> (n, `px)

(** Computes font_size in px when possible from absolute size or
  size relative to parent. *)
let font_size props ~root ~parent t v =
  let p = font_size in
  let of_parent_factor parent f =
    let f = match f with
      | `Smaller -> 0.9
      | `Larger -> 1.1
      | `Percent p -> p /. 100.
    in
    match get parent p with
    | `Length (np, (#T.abs_length_unit as u)) ->
        let np = to_px np u in
        Some (np *. f, `px)
    | _ -> None
  in
  match v with
  | `Length len ->
      let (n,u) = length props ~root ~parent parent len in
      (`Length (n,u))
  | (`Smaller | `Larger | `Percent _) as f ->
      (match of_parent_factor parent f with
       | None -> v
       | Some (n,u) -> (`Length (n,u))
      )
  | kw ->
      let n = !px_of_font_size_kw kw in
      (`Length (n, `px))

let font_weight props ~root ~parent t =
  let of_parent parent f =
    match get parent P.font_weight with
    | `Weight n -> `Weight (max 100 (min 900 (f n)))
    | x ->
        Log.debug (fun m -> m "computing %s: parent is not a `Weight value (%a)"
           (P.name font_weight) T.pp_font_weight x);
        (P.initial font_weight)
  in
 function
  | `Bolder -> of_parent parent ((+) 100)
  | `Lighter -> of_parent parent ((-) 100)
  | `Normal -> `Weight 400
  | `Bold -> `Weight 700
  | x -> x

let size props ~root ~parent t = function
| `Length len -> `Length (length props ~root ~parent t len)
| x -> x

let line_height props ~root ~parent t = function
| `Length len -> let len = length props ~root ~parent t len in `Length len
| #T.line_height as x -> x

let word_spacing props ~root ~parent t = function
| `Length len -> let len = length props ~root ~parent t len in `Length len
| #T.word_spacing as x -> x

let mandatory_value prop_name = function
| `V v -> v
| `Var (name,_) ->
    prerr_endline (Printf.sprintf "Property %s: a default value cannot be `Var(%s)" prop_name name);
    assert false

let border_spacing props ~root ~parent t (x, y) =
  let def_x, def_y = P.initial P.border_spacing in
  let mand = mandatory_value "border-spacing" in
  let def_x = mand def_x in
  let def_y = mand def_y in
  let x = or_var props Vp.length length ~root ~parent t def_x x in
  let y = or_var props Vp.length length ~root ~parent t def_y y in
  (x, y)

let border_width_of_kw = ref (function
| `Thin -> 1.
| `Medium -> 2.
| `Thick -> 3.)

let border_width props ~root ~parent t = function
| #T.border_width_kw as kw -> `Length (!border_width_of_kw kw, `px)
| x -> size props ~root ~parent t x

let font_family_of_generic : (T.font_family_generic_kw -> string) ref =
  let f = function
  | `Cursive -> "Purisa"
  | `Emoji -> "OpenSymbol"
  | `Fantasy -> "Verdana"
  | `Fangsong -> "Noto Sans CJK"
  | `Math -> "DejaVu Math Tex Gyre"
  | `Monospace -> "DejaVu Sans Mono"
  | `Sans_serif -> "DejaVu Sans"
  | `Serif -> "DejaVu Serif"
  | `System_ui -> "DejaVu Sans"
  | `Ui_monospace -> "DejaVu Sans Mono"
  | `Ui_rounded -> "DejaVu Serif"
  | `Ui_sans_serif -> "DejaVu Sans"
  | `Ui_serif -> "DejaVu Serif"
  in
  ref f

let font_family_ props ~root ~parent t = function
| `Generic x ->
    let family = !font_family_of_generic x in
    Log.info (fun m -> m "Css.C.font_family_: using %S for generic %S" family (Kw.string_of_kw x) );
    `Family family
| #T.font_family_ as x -> x

let font_family props ~root ~parent t l =
  List.map (font_family_ props ~root ~parent t) l

let max_size props ~root ~parent t = function
| `Length len -> `Length (length props ~root ~parent t len)
| x -> x

let margin props ~root ~parent t = function
| `Length len -> `Length (length props ~root ~parent t len)
| x -> x

let padding props ~root ~parent t = function
| `Length len -> `Length (length props ~root ~parent t len)
| x -> x

let vertical_align props ~root ~parent t = function
| `Length len -> `Length (length props ~root ~parent t len)
| x -> x


(** {2 Associating computation functions to properties} *)

type binding = B : 'a prop * ((module P.Prop_space) -> root:t -> parent:t -> t -> 'a P.value -> t) -> binding

(**/**)

let prop_funs : binding P.M.t ref = ref P.M.empty

(**/**)

(** [comp f p props ~root ~parent t v] computes value of property [p]
  from its parsed value [v], in the context of [root] and
  [parent] maps.
  [f] is applied on:
  {ul
   {- the result of recursive expansion if [v] is a variable,}
   {- the result of {!comp_global} if [v] is a global keyword,}
   {- else [v].}
  }
  The resulting computed value is then added to [t] for property [p].
*)
let comp f p props ~root ~parent t v =
  let v =
    match v.v with
    | `Var (name, default) ->
        let parser = P.parser p in
        (match expand props parser t name default with
         | None ->
             let module PS = (val props : P.Prop_space) in
             Log.warn (fun m -> m "[%s]could not fully expand %s with %a@.t=%a"
                PS.space_name (P.name p) (P.pp_value p) v.v pp t);
             (P.initial p)
         | Some x ->
             (*Log.warn (fun m -> m "%s expanded to %a" (P.name p) (P.pp p) x);*)
             x
        )
    | #T.global_kw as x -> comp_global ~parent p x
    | `V vv -> vv
  in
  let v = f props ~root ~parent t v in
  Computed.add t p v

(** [map props ~root ~parent t v] returns [v], without any computation.
  This is the default computation for several properties. *)
let map props ~root ~parent t v = v

(** [register_prop_fun p f] registers [f] as computation function
  for values of property [p]. This can be used to override or specify the
  computation function of a property. *)
let register_prop_fun p f =
  prop_funs := P.M.add p (B(p, comp f p)) !prop_funs

(** {2 Computing from declarations} *)

let compute_decl props ~root ~parent t (P.B (p, v)) =
  match P.M.find_opt p !prop_funs with
  | None when P.is_var p ->
      Log.debug (fun m -> m "C.compute_decl prop=%s (var)" (P.name p));
      comp map p props ~root ~parent t v
  | None ->
      Log.warn (fun m -> m "No computation fun for property %s" (P.name p));
      t
  | Some (B (p0,f)) ->
      Log.debug (fun m -> m "C.compute_decl prop=%s" (P.name p0));
      match P.(eq (tid p) (tid p0)) with
      | Some P.Teq -> f props ~root ~parent t v
      | None -> t

(** [compute_decls props ~root ~parent t decls] performs computations of the
  given declarations [decls] in the environment of [root] computed values,
  [parent] computed values and current computed values [t].*)
let compute_decls props ~root ~parent t decls =
  List.fold_left (compute_decl props ~root ~parent) t decls

let () =
  let r = register_prop_fun in
  r P.accent_color accent_color ;
  r P.align_content map ;
  r P.align_items map ;
  r P.align_self map ;
  r P.aspect_ratio map ;
  r P.background_attachment map ;
  r P.background_clip map ;
  r P.background_image map ;
  r P.background_origin map ;
  r P.background_position_x map ;
  r P.background_position_y map ;
  r P.background_repeat map ;
  r P.background_size map; (* FIXME: compute length *)
  r P.background_color color ;
  r P.block_size map ; (* FIXME *)
  r P.border_collapse map ;
  r P.border_spacing border_spacing ;
  r P.border_top_color color ;
  r P.border_top_style map ;
  r P.border_top_width border_width ;
  r P.border_right_color color ;
  r P.border_right_style map ;
  r P.border_right_width border_width ;
  r P.border_bottom_color color ;
  r P.border_bottom_style map ;
  r P.border_bottom_width border_width ;
  r P.border_left_color color ;
  r P.border_left_style map ;
  r P.border_left_width border_width ;
  r P.color color ;
  r P.display map ;
  r P.flex_basis map ;
  r P.flex_direction map ;
  r P.flex_grow map ;
  r P.flex_shrink map ;
  r P.flex_wrap map ;
  r P.font_family font_family ;
  r P.font_kerning map ;
  r P.font_size font_size ;
  r P.font_stretch map ;
  r P.font_style map ;
  r P.font_variant_alternates map ;
  r P.font_variant_caps map ;
  r P.font_variant_east_asian map ;
  r P.font_variant_emoji map ;
  r P.font_variant_ligatures map ;
  r P.font_variant_numeric map ;
  r P.font_variant_position map ;
  r P.font_weight font_weight ;
  r P.height size ;
  r P.inline_size size ;
  r P.justify_content map ;
  r P.justify_items map ;
  r P.justify_self map ;
  r P.line_height line_height ;
  r P.list_style_image map ;
  r P.list_style_position map ;
  r P.list_style_type map ;
  r P.margin_top margin ;
  r P.margin_right margin ;
  r P.margin_bottom margin ;
  r P.margin_left margin ;
  r P.max_height max_size ;
  r P.max_width max_size ;
  r P.min_height size ;
  r P.min_width size ;
  r P.opacity map ;
  r P.padding_top padding ;
  r P.padding_right padding ;
  r P.padding_bottom padding ;
  r P.padding_left padding ;
  r P.position map ;
  r P.text_align map ;
  r P.text_align_last map ;
  r P.vertical_align vertical_align ;
  r P.visibility map ;
  r P.white_space map ;
  r P.word_spacing word_spacing ;
  r P.width size