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

(** Properties *)

(* Code copied and adapted from Daniel C. Bünzli'a Hmap. All rights reserved.
   Distributed under the ISC license. *)

module Tid = struct type _ t = .. end
module type Tid = sig
  type t
  type _  Tid.t += Tid : t Tid.t
end

type 'a tid = (module Tid with type t = 'a)

let gen_tid () (type s) =
  let module M = struct
    type t = s
    type _ Tid.t += Tid : t Tid.t
  end
  in
  (module M : Tid with type t = s)

type ('a, 'b) teq = Teq : ('a, 'a) teq

let eq : type r s. r tid -> s tid -> (r, s) teq option =
  fun r s ->
    let module R = (val r : Tid with type t = r) in
    let module S = (val s : Tid with type t = s) in
    match R.Tid with
    | S.Tid -> Some Teq
    | _ -> None

(* End of copied and adapted code*)

let gen_pid = let cpt = ref (-1) in fun () -> incr cpt; !cpt

type 'a value = { v : 'a T.p_value; loc: T.loc; important: bool }

type 'a prop =
  { pid : int ;
    tid : 'a tid;
    name : string ;
    parser : T.ctx -> start:T.pos -> 'a value Angstrom.t ;
    to_string : 'a -> string ;
    pp : Format.formatter -> 'a -> unit ;
    inherited : bool ;
    initial : 'a ;
  }

let initial p = p.initial
let name p = p.name
let parser p = p.parser
let to_string p = p.to_string
let pp p = p.pp
let inherited p = p.inherited
let tid p = p.tid

module Key =
  struct
    type t = V : 'a prop -> t
    let compare (V k1) (V k2) = Int.compare k1.pid k2.pid
  end
let compare_prop p1 p2 = Key.(compare (V p1) (V p2))

module M = struct
    include Map.Make(Key)
    let find_opt p t = find_opt (Key.V p) t
    let add p v t = add (Key.V p) v t
  end

type binding = B : 'a prop * 'a value -> binding

let add t p v = M.add p (B (p,v)) t
type t = binding M.t
let empty = M.empty
let fold f acc t = M.fold (fun _ b acc -> f b acc) acc t
let iter f t = M.iter (fun _ b -> f b) t
let filter f t = M.filter (fun _ b -> f b) t
let to_list t = List.map snd (M.bindings t)


let value_to_string : 'a prop -> ('a T.p_value -> string) =
  fun p -> T.string_of_p_value p.to_string
let pp_value : 'a prop -> (Format.formatter -> 'a T.p_value -> unit) =
  fun p -> T.pp_p_value p.pp

let opt : type a. t -> a prop -> a value option = fun t p ->
    match M.find_opt p t with
    | None -> None
    | Some (B (p2,v)) ->
        match eq p.tid p2.tid with
        | Some Teq -> Some v
        | _ -> None

let get t p =
  match opt t p with
  | None -> (`V p.initial)
  | Some v -> v.v

let add_v t p v = M.add p (B (p,v)) t
let add t p v loc important =
  let v = { v ; loc ; important } in add_v t p v
let add_vl t p (v,loc) = add t p (`V v) loc false

let add_with_important t p v loc ctx =
  let open Angstrom in
  Vp.important ctx >>| add t p v loc
let set_important t p important =
  match opt t p with
  | None -> t
  | Some v -> add_v t p { v with important }

let v_initial p =
  { v = `V p.initial; loc = T.dummy_loc ; important = false }

let merge t1 t2 = M.union (fun _ _ v -> Some v) t1 t2

let filter_inherited t = filter (fun (B (p,_)) -> p.inherited) t


let is_prefix ~s ~pref =
  let len_s = String.length s in
  let len_pref = String.length pref in
  (len_pref <= len_s) &&
    (String.sub s 0 len_pref) = pref

module type Prop_space =
  sig
    type p = P : 'a prop -> p
    val space_name : string
    val register : 'a prop -> unit
    val register_prop_parser :
      string -> (T.ctx -> T.pos -> t -> t Angstrom.t) ->  unit
    val mk_prop :
      string -> ?register_prop:bool -> ?inherited:bool ->
        'a -> ('a -> string) -> ?pp:(Format.formatter -> 'a -> unit) ->
        (T.ctx -> 'a Angstrom.t) -> 'a prop
    val props : unit -> p M.t
    val get_var_prop : string -> string prop option
    val parse_and_add_by_name :
      string ->
        (T.ctx -> Stdlib.Lexing.position -> t -> t Angstrom.t) option
    val parse_and_add :
      'a prop ->
        (T.ctx -> Stdlib.Lexing.position -> t -> t Angstrom.t) option
    val mk_var_prop : string -> string prop
  end

let is_var_name name = is_prefix ~s:name ~pref:"--"
let is_var p = is_var_name p.name

module type Prop_space_name = sig val name : string end
module Mk_prop_space (P:Prop_space_name) : Prop_space =
  struct
    module Smap = T.Smap
    let space_name = P.name
    let prop_parsers : (T.ctx -> Lexing.position -> t -> t Angstrom.t) Smap.t ref = ref Smap.empty
    let register_prop_parser name f =
      prop_parsers := Smap.add name f !prop_parsers
    type p = P : 'a prop -> p
    let props : p M.t ref = ref M.empty
    let register p = props := M.add p (P p) !props
    let parser_of_prop_name name = Smap.find_opt name !prop_parsers
    let var_props = ref T.Smap.empty
    let get_var_prop name = T.Smap.find_opt name !var_props

    let mk_prop name ?(register_prop=true) ?(inherited=false) initial to_string ?pp
      (parser : T.ctx -> 'a Angstrom.t) : 'a prop =
      let pp = match pp with
        | Some f -> f
        | None -> T.mk_pp to_string
      in
      let open Angstrom in
      let parser ctx ~start =
        (if is_var_name name
         then parser ctx >>= fun v -> return (`V v)
         else Vp.p_value parser ctx) >>= fun v ->
        Vp.important ctx >>= fun important ->
          ctx.T.get_pos >>=
          fun stop ->
            let loc = (start, stop) in
            return { v ; loc; important }
      in
      let pid = gen_pid () in
      let tid = gen_tid () in
      let p = { pid ; tid ; name ; parser ; to_string ; pp ; inherited ; initial } in
      let f ctx start t = p.parser ctx ~start >>|
        fun v ->
          Log.debug (fun m -> m "[%s]adding %s=%a" space_name p.name
             (pp_value p) v.v);
          add_v t p v
      in
      if register_prop then register p ;
      register_prop_parser p.name f;
      p

    let props () = !props

    let mk_var_prop : (string -> string prop) = fun name ->
      let p = mk_prop name ~register_prop:true ~inherited:true
        "" (fun x -> x) Vp.var_value
      in
      var_props := T.Smap.add name p !var_props;
      p

    let rec parse_and_add_by_name name =
      let name = String.lowercase_ascii name in
      match Smap.find_opt name !prop_parsers with
      | Some f -> Some f
      | None ->
          (* if it is a custom property, create it *)
          match is_var_name name with
          | false ->
              None
          | true ->
              Log.debug (fun m -> m "[%s]creating custom property %S" space_name name);
              ignore(mk_var_prop name);
              parse_and_add_by_name name

    let parse_and_add prop = parse_and_add_by_name prop.name
  end
let mk_prop_space name =
  let module S = Mk_prop_space (struct let name = name end) in
  (module S : Prop_space)

module Css = (val  mk_prop_space "css3")

let mk_prop = Css.mk_prop

let accent_color : T.accent_color prop = mk_prop "accent-color"
  ~inherited:true `Auto T.string_of_accent_color Vp.accent_color
let align_content : T.align_content prop = mk_prop "align-content"
  ~inherited:false `Normal T.string_of_align_content Vp.align_content
let align_items : T.align_items prop = mk_prop "align-items"
  ~inherited:false `Normal T.string_of_align_items Vp.align_items
let align_self : T.align_self prop = mk_prop "align-self"
  ~inherited:false `Auto T.string_of_align_self Vp.align_self

let aspect_ratio : T.aspect_ratio prop = mk_prop "aspect-ratio"
  ~inherited:false `Auto T.string_of_aspect_ratio Vp.aspect_ratio

let background_attachment : T.background_attachment prop =
  mk_prop "background-attachment"
    ~inherited:false [`Scroll]
    T.string_of_background_attachment
     Vp.background_attachment

let background_clip : T.background_clip prop =
  mk_prop "background-clip"
    ~inherited:false [`Border_box]
    T.string_of_background_clip Vp.background_clip

let background_color : T.background_color prop =
  mk_prop "background-color"
  ~inherited:false `Transparent
    T.string_of_background_color Vp.background_color

let background_image : T.background_image prop =
  mk_prop "background-image"
    ~inherited:false [`None]
    T.string_of_background_image Vp.background_image

let background_origin : T.background_origin prop =
  mk_prop "background-origin"
    ~inherited:false [`Padding_box]
    T.string_of_background_origin Vp.background_origin

let background_position_x : T.background_position_x prop =
  mk_prop "background-position-x"
  ~inherited:false [T.Offset (`Percent 0.)]
    T.string_of_background_position_x Vp.background_position_x

let background_position_y : T.background_position_y prop =
  mk_prop "background-position-y"
  ~inherited:false [T.Offset (`Percent 0.)]
    T.string_of_background_position_y Vp.background_position_y

let background_repeat : T.background_repeat prop =
  mk_prop "background-repeat"
  ~inherited:false [(`Repeat, `Repeat)]
    T.string_of_background_repeat Vp.background_repeat

let background_size : T.background_size prop =
  mk_prop "background-size"
  ~inherited:false [(`Auto, `Auto)]
    T.string_of_background_size Vp.background_size

let block_size : T.size prop =
  mk_prop "block-size"
    ~inherited:false `Auto T.string_of_size Vp.size

let border_collapse : T.border_collapse prop =
  mk_prop "border-collapse"
    ~inherited:true `Separate T.string_of_border_collapse Vp.border_collapse

let border_spacing : T.border_spacing prop =
  mk_prop "border-spacing"
    ~inherited:true ((0.,`px),(0.,`px))
    T.string_of_border_spacing
    Vp.border_spacing

let mk_border_props side =
  let side = T.string_of_side side in
  let name s = Printf.sprintf "border-%s-%s" side s in
  let c = mk_prop (name "color") ~inherited:false `Current_color
    T.string_of_color Vp.color
  in
  let s = mk_prop (name "style") ~inherited:false `None
    T.string_of_line_style Vp.line_style
  in
  let w = mk_prop (name "width") ~inherited:false `Medium
    T.string_of_border_width Vp.border_width
  in
  (c,s,w)

let (border_top_color, border_top_style, border_top_width)
  as border_top = mk_border_props `Top
let (border_right_color, border_right_style, border_right_width)
  as border_right = mk_border_props `Right
let (border_bottom_color, border_bottom_style, border_bottom_width)
  as border_bottom = mk_border_props `Bottom
let (border_left_color, border_left_style, border_left_width)
  as border_left = mk_border_props `Left

let color : T.color prop = mk_prop "color"
  ~inherited:true `Current_color T.string_of_color Vp.color

let display : T.display prop = mk_prop "display"
  ~inherited:false (`Out_in(`Inline, `Flow, None))
    T.string_of_display Vp.display

let flex_basis : T.flex_basis prop = mk_prop "flex-basis"
  ~inherited:false `Auto
    T.string_of_flex_basis Vp.flex_basis

let flex_direction : T.flex_direction prop = mk_prop "flex-direction"
  ~inherited:false `Row
    T.string_of_flex_direction Vp.flex_direction

let flex_grow : T.number prop = mk_prop "flex-grow"
  ~inherited:false 0.
    T.string_of_number Vp.number

let flex_shrink : T.number prop = mk_prop "flex-shrink"
  ~inherited:false 1.
    T.string_of_number Vp.number

let flex_wrap : T.flex_wrap prop = mk_prop "flex-wrap"
  ~inherited:false `Nowrap
    T.string_of_flex_wrap Vp.flex_wrap

let font_family : T.font_family prop = mk_prop "font-family"
  ~inherited:true [`Generic `Serif]
    T.string_of_font_family Vp.font_family

let font_kerning : T.font_kerning prop =
  mk_prop "font-kerning"
  ~inherited:true `Normal
    T.string_of_font_kerning Vp.font_kerning

let font_size : T.font_size prop = mk_prop "font-size"
  ~inherited:true `Medium
    T.string_of_font_size Vp.font_size

let font_stretch : T.font_stretch prop = mk_prop "font-stretch"
  ~inherited:true `Normal
    T.string_of_font_stretch Vp.font_stretch

let font_style : T.font_style prop = mk_prop "font-style"
  ~inherited:true `Normal
    T.string_of_font_style Vp.font_style

let font_variant_alternates : T.font_variant_alternates prop =
  mk_prop "font-variant-alternates"
  ~inherited:true `Normal
    T.string_of_font_variant_alternates Vp.font_variant_alternates

let font_variant_caps : T.font_variant_caps prop =
  mk_prop "font-variant-caps"
  ~inherited:true `Normal
    T.string_of_font_variant_caps Vp.font_variant_caps

let font_variant_east_asian : T.font_variant_east_asian prop =
  mk_prop "font-variant-east_asian"
  ~inherited:true `Normal
    T.string_of_font_variant_east_asian Vp.font_variant_east_asian

let font_variant_emoji : T.font_variant_emoji prop =
  mk_prop "font-variant-emoji"
  ~inherited:true `Normal
    T.string_of_font_variant_emoji Vp.font_variant_emoji

let font_variant_ligatures : T.font_variant_ligatures prop =
  mk_prop "font-variant-ligatures"
  ~inherited:true `Normal
    T.string_of_font_variant_ligatures Vp.font_variant_ligatures

let font_variant_numeric : T.font_variant_numeric prop =
  mk_prop "font-variant-numeric"
  ~inherited:true `Normal
    T.string_of_font_variant_numeric Vp.font_variant_numeric

let font_variant_position : T.font_variant_position prop =
  mk_prop "font-variant-position"
  ~inherited:true `Normal
    T.string_of_font_variant_position Vp.font_variant_position

let font_weight : T.font_weight prop =
  mk_prop "font-weight"
  ~inherited:true `Normal
    T.string_of_font_weight Vp.font_weight

let height : T.height prop = mk_prop "height"
  ~inherited:false `Auto T.string_of_height Vp.size

let inline_size : T.size prop =
  mk_prop "inline-size"
    ~inherited:false `Auto T.string_of_size Vp.size

let justify_content : T.justify_content prop = mk_prop "justify-content"
  ~inherited:false `Normal T.string_of_justify_content Vp.justify_content

let justify_items : T.justify_items prop = mk_prop "justify-items"
  ~inherited:false `Legacy T.string_of_justify_items Vp.justify_items

let justify_self : T.justify_self prop = mk_prop "justify-self"
  ~inherited:false `Auto T.string_of_justify_self Vp.justify_self

let line_height : T.line_height prop =
  mk_prop "line-height"
  ~inherited:true `Normal
    T.string_of_line_height Vp.line_height

let list_style_image : T.list_style_image prop = mk_prop "list-style-image"
  ~inherited:true `None T.string_of_list_style_image Vp.list_style_image

let list_style_position : T.list_style_position prop = mk_prop "list-style-position"
  ~inherited:true `Outside T.string_of_list_style_position Vp.list_style_position

let list_style_type : T.list_style_type prop = mk_prop "list-style-type"
  ~inherited:true (`Ident_ "disc") T.string_of_list_style_type Vp.list_style_type

let mk_margin side =
  let name = Printf.sprintf "margin-%s" (T.string_of_side side) in
  mk_prop name ~inherited:false (`Length (0.,`px))
    T.string_of_margin Vp.margin

let (margin_top, margin_right, margin_bottom, margin_left) as margins =
  (mk_margin `Top, mk_margin `Right, mk_margin `Bottom, mk_margin `Left)

let max_height : T.max_size prop = mk_prop "max-height"
  ~inherited:false `None
    T.string_of_max_size (Vp.max_size ~name:"max-height")
let max_width : T.max_size prop = mk_prop "max-width"
  ~inherited:false `None
    T.string_of_max_size (Vp.max_size ~name:"max-width")

let min_height : T.size prop = mk_prop "min-height"
  ~inherited:false `Auto
    T.string_of_size (Vp.size ~name:"min-height")

let min_width : T.size prop = mk_prop "min-width"
  ~inherited:false `Auto
    T.string_of_size (Vp.size ~name:"min-width")

let opacity : T.opacity prop = mk_prop "opacity"
  ~inherited:false (`Factor 1.)
    T.string_of_opacity Vp.opacity

let mk_padding side =
  let name = Printf.sprintf "padding-%s" (T.string_of_side side) in
  mk_prop name ~inherited:false (`Length (0.,`px))
    T.string_of_padding Vp.padding

let (padding_top, padding_right, padding_bottom, padding_left) as paddings =
  (mk_padding `Top, mk_padding `Right, mk_padding `Bottom, mk_padding `Left)

let position : T.position prop = mk_prop "position"
  ~inherited:false `Static T.string_of_position Vp.position

let text_align : T.text_align prop = mk_prop "text-align"
  ~inherited:true `Start T.string_of_text_align Vp.text_align

let text_align_last : T.text_align_last prop = mk_prop "text-align-last"
  ~inherited:true `Start T.string_of_text_align_last Vp.text_align_last

let vertical_align : T.vertical_align prop = mk_prop "vertical-align"
  ~inherited:true `Baseline T.string_of_vertical_align Vp.vertical_align

let visibility : T.visibility prop = mk_prop "visibility"
  ~inherited:false `Visible T.string_of_visibility Vp.visibility

let white_space : T.white_space prop = mk_prop "white-space"
  ~inherited:true `Normal T.string_of_white_space Vp.white_space

let word_spacing : T.word_spacing prop = mk_prop "word-spacing"
  ~inherited:true `Normal T.string_of_word_spacing Vp.word_spacing

let width : T.width prop = mk_prop "width"
  ~inherited:false `Auto T.string_of_width Vp.size