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

[@@@landmark "auto"]

exception Property_exists of string

type 'a post_action =
  | Resize
  | Render
  | Action of ('a -> unit)

module Id = Misc.Id ()

type 'a prop = Id.t

type 'a transition = start:'a -> stop:'a -> float -> 'a

let dummy_trans ~start ~stop _ = stop

type prop_value = ..

module type Prop = sig
    val id : Id.t
    type t
    val name : string
    val compare : t -> t -> int
    val wrapper : t Ocf.Wrapper.t option
    val from_prop_value : prop_value -> t
    val to_prop_value : t -> prop_value
    val after : t post_action list
    val default : t option
    val inherited : bool
    val transition : t transition option
  end

let props = ref ([| |] : (module Prop) array)
let props_by_name = ref Smap.empty

let get_prop id =
  try !props.(Id.to_int id)
  with _ -> Log.err (fun m -> m "Invalid prop id %a" Id.pp id); assert false
let name id = let module P = (val get_prop id : Prop) in P.name
let prop_wrapper : 'a prop -> 'a Ocf.Wrapper.t option =
  fun id -> let module P = (val get_prop id : Prop) in Obj.magic P.wrapper
let inherited id = let module P = (val get_prop id : Prop) in P.inherited
let default_value : 'a prop -> 'a option =
  fun id -> let module P = (val get_prop id : Prop) in Obj.magic P.default
let transition : 'a prop -> 'a transition option =
  fun id -> let module P = (val get_prop id : Prop) in Obj.magic P.transition
let after : 'a prop -> 'a post_action list =
  fun id -> let module P = (val get_prop id : Prop) in Obj.magic P.after
let to_prop_value : 'a prop -> 'a -> prop_value =
  fun id v -> let module P = (val get_prop id) in P.to_prop_value (Obj.magic v)

let from_prop_value : 'a prop -> prop_value -> 'a =
  fun id v ->
    let module P = (val get_prop id) in
    Obj.magic (P.from_prop_value v)

module Map = Id.Map
type t = { mutable t : prop_value Map.t }

let empty () = { t = Map.empty }

let set : t -> 'a prop -> 'a -> unit =
  fun t id v ->
    t.t <- Map.add id (to_prop_value id v) t.t

let set_opt t p = function
| None -> t.t <- Map.remove p t.t
| Some v -> set t p v

let var_of_string str =
 let len = String.length str in
  if len > 0 && String.get str 0 = '$' then
    Some (String.sub str 1 (len - 1))
  else
    None

let map_set_from_json = ref Smap.empty
let set_prop_from_json ?vars t name json =
  match Smap.find_opt name !map_set_from_json with
  | None -> ()
  | Some f -> f ?vars t json

let set_from_json ?vars t = function
| `Assoc l ->
    List.iter (fun (name,json) -> set_prop_from_json ?vars t name json) l
| _ ->
    Log.err (fun m -> m "Props.set_from_json: not an `Assoc")
let to_json ?with_doc t =
  let f id (v:prop_value) acc =
    let module P = (val get_prop id : Prop) in
    match P.wrapper with
    | None -> acc
    | Some w -> (P.name, w.to_json ?with_doc (P.from_prop_value v)) :: acc
  in
  `Assoc (Map.fold f t.t [])

let rec expand_json vars json =
  match json with
  | `String s ->
      (
       match var_of_string s with
       | None -> json
       | Some v ->
           match Smap.find_opt v vars with
           | None ->
               Log.warn (fun m -> m "Unknown variable %s" s);
               json
           | Some json -> expand_json vars json
      )
  | `Assoc l ->
      `Assoc (List.map (fun (str, json) -> (str, expand_json vars json)) l)
  | `List l -> `List (List.map (expand_json vars) l)
  | `Tuple l -> `Tuple (List.map (expand_json vars) l)
  | `Variant (x,Some json) -> `Variant (x, Some (expand_json vars json))
  | _ -> json

let wrapper =
  let from_json ?def json =
    let t = empty() in
    set_from_json t json ;
    t
  in
  Ocf.Wrapper.make to_json from_json

let compare_prop_value = ref (fun v1 v2 -> assert false)
let register_compare_prop_value f =
  let c = !compare_prop_value in
  compare_prop_value := f c

module type PT = sig
    type t
    val compare : t -> t -> int
    val wrapper : t Ocf.Wrapper.t option
    val transition : t transition option
  end
type 'a mk_prop =
  ?after:'a post_action list ->
    ?default:'a -> ?inherited:bool ->
    ?transition:'a transition -> string -> 'a prop

module type Prop_type = sig
    include PT
    val from_prop_value : prop_value -> t
    val to_prop_value : t -> prop_value
    val mk_prop : t mk_prop
  end
let register_prop p =
  let module P = (val p : Prop) in
  (match Id.to_int P.id with
   | 0 -> (* first prop *)
       props := Array.make 1 p
   | n when n > 0 ->
       let props2 = Array.make (n+1) p in
       Array.blit !props 0 props2 0 (Array.length !props);
       props := props2
   | _ -> assert false
  );
  props_by_name := Smap.add P.name P.id !props_by_name


let prop_to_string : 'a prop -> 'a -> string =
  fun p v ->
    let module P = (val get_prop p : Prop) in
    match P.wrapper with
    | None -> "<no printer>"
    | Some w -> Yojson.Safe.to_string (w.to_json (Obj.magic v))

module Add_prop_type (T:PT) =
  struct
    type t = T.t
    type prop_value += V of T.t
    let comp fallback v1 v2 =
      match v1, v2 with
      | V v1, V v2 -> T.compare v1 v2
      | V _, _ -> -1
      | _, V _ -> 1
      | _ -> fallback v1 v2
    let () = register_compare_prop_value comp
    let compare = T.compare
    let wrapper = T.wrapper
    let transition = T.transition
    let from_prop_value = function
    | V v -> v
    | x -> assert false
    let to_prop_value v = V v
    let mk_prop : ?after: T.t post_action list ->
      ?default:T.t -> ?inherited:bool -> ?transition:T.t transition -> string -> T.t prop =
    fun ?(after=[]) ?default ?(inherited=true) ?transition name ->
      match Smap.find_opt name !props_by_name with
      | Some _ -> raise (Property_exists name)
      | None ->
          let id = Id.gen () in
          let module M = struct
            type t = T.t
            let id = id
            let name = name
            let compare = T.compare
            let wrapper = T.wrapper
            let from_prop_value = from_prop_value
            let to_prop_value = to_prop_value
            let after = after
            let default = default
            let inherited = inherited
            let transition = match transition with None -> T.transition | x -> x
            end
          in
          let set_from_json ?vars t json =
            match M.wrapper with
            | None -> ()
            | Some w ->
                match json with
                | `Null -> set_opt t id None
                | json ->
                    let json = match vars with
                      | None -> json
                      | Some vars -> expand_json vars json
                    in
                    let v = w.Ocf.Wrapper.from_json ?def:default json in
                    set t id v
          in
          map_set_from_json := Smap.add name set_from_json !map_set_from_json;
          register_prop (module M);
          id
  end

let int_transition ~start ~stop r =
  truncate (float start +. (min 1. r) *. (float (stop - start)))
module TInt = struct
    type t = int
    let compare = Int.compare
    let wrapper = Some Ocf.Wrapper.int
    let transition = Some int_transition
  end
module PInt = Add_prop_type(TInt)

let float_transition ~start ~stop r = start +. (min 1. r) *. (stop -. start)
module PFloat = Add_prop_type(struct
     type t = float
     let compare = Float.compare
     let wrapper = Some Ocf.Wrapper.float
     let transition = Some float_transition
   end)

module PBool = Add_prop_type(struct
     type t = bool
     let compare = Bool.compare
     let wrapper = Some Ocf.Wrapper.bool
     let transition = Some
       (fun ~start ~stop r -> if r >= 1. then stop else start)
   end)
module PString = Add_prop_type(struct
     type t = string
     let compare = String.compare
     let wrapper = Some Ocf.Wrapper.string
     let transition = None
   end)
module TUchar = struct
    type t = Uchar.t
    let compare = Uchar.compare
    let wrapper =
      let to_json ?with_doc c = `Int (Uchar.to_int c) in
      let from_json ?def = function
      | `Int n -> Uchar.of_int n
      | json -> Ocf.invalid_value json
      in
      Some (Ocf.Wrapper.make to_json from_json)
    let transition = None
  end
module PUchar = Add_prop_type(TUchar)

module TColor = struct
    type t = Color.t
    let compare = Color.compare
    let wrapper = Some Color.ocf_wrapper
    let transition =
      let f ~start ~stop q =
        let (r,g,b,a) = Color.to_int8s start in
        let (r2,g2,b2,a2) = Color.to_int8s stop in
        let r = int_transition ~start:r ~stop:r2 q in
        let g = int_transition ~start:g ~stop:g2 q in
        let b = int_transition ~start:b ~stop:b2 q in
        let a = int_transition ~start:a ~stop:a2 q in
        Color.of_rgba r g b a
      in
      Some f
  end
module PColor = Add_prop_type(TColor)

module PFont_desc = Add_prop_type(struct
  type t = Font.font_desc
  let compare = Font.font_desc_compare
  let wrapper = Some Font.font_desc_wrapper
  let transition = None
   end)

let compare p1 p2 = Map.compare !compare_prop_value p1.t p2.t
module TProps = struct
    type nonrec t = t
    let compare = compare
    let wrapper = Some wrapper
    let transition = None
  end
module PProps = Add_prop_type(TProps)

module TKeystate = struct
    type t = Key.keystate
    let compare = Key.compare_keystate
    let wrapper = Some Key.keystate_ocf_wrapper
    let transition = None
  end
module PKeystate = Add_prop_type(TKeystate)

type 'a trbl = { top: 'a ; right: 'a; bottom: 'a; left: 'a }

let trbl ~top ~right ~bottom ~left = { top ; right ; bottom ; left }
let trbl_ top right bottom left = { top ; right ; bottom ; left }
let trbl__ x = trbl_ x x x x
let trbl_of ?top ?right ?bottom ?left t =
  let top = Option.fold ~none:t.top ~some:(fun x -> x) top in
  let right = Option.fold ~none:t.right ~some:(fun x -> x) right in
  let bottom = Option.fold ~none:t.bottom ~some:(fun x -> x) bottom in
  let left = Option.fold ~none:t.left ~some:(fun x -> x) left in
  trbl ~top ~right ~bottom ~left

let trbl_compare compare t1 t2 =
  match compare t1.top t2.top with
  | 0 ->
      (match compare t1.right t2.right with
       | 0 ->
           (match compare t1.bottom t2.bottom with
            | 0 -> compare t1.left t2.left
            | n -> n
           )
       | n -> n
      )
  | n -> n

let trbl_ocf_wrapper w =
  let to_j ?with_doc t =
     `Assoc [
      "top", w.Ocf.Wrapper.to_json ?with_doc t.top ;
      "right", w.to_json ?with_doc t.right ;
      "bottom", w.to_json ?with_doc t.bottom ;
      "left", w.to_json ?with_doc t.left ;
      ]
  in
  let from_j ?def = function
  | `List [t;r;b;l] -> trbl_
      (w.Ocf.Wrapper.from_json t) (w.from_json r) (w.from_json b) (w.from_json r)
  | `List [tb;rl] ->
      let tb = w.from_json tb in
      let rl = w.from_json rl in
      trbl_ tb rl tb rl
  | `Assoc l ->
      begin
        let get fd = Option.map (w.from_json ?def:None) (List.assoc_opt fd l) in
        match get "top", get "right", get "bottom", get "left" with
        | Some top, Some right, Some bottom, Some left ->
            trbl ~top ~right ~bottom ~left
        | top, right, bottom, left ->
            match def with
            | Some d ->  trbl_of ?top ?right ?bottom ?left d
            | None -> Ocf.json_error
                (Printf.sprintf "Missing field (top|right|bottom|left) in %s"
                 (Yojson.Safe.to_string (`Assoc l)))
      end

  | json -> trbl__ (w.from_json json)
  in
  Ocf.Wrapper.make to_j from_j

let trbl_transition f ~start ~stop r =
  { top = f ~start:start.top ~stop:stop.top r ;
    right = f ~start:start.right ~stop:stop.right r ;
    bottom = f ~start:start.bottom ~stop:stop.bottom r ;
    left = f ~start:start.left ~stop:stop.left r ;
  }

module PTrbl (T:PT) =
  Add_prop_type(struct
     type t = T.t trbl
     let compare = trbl_compare T.compare
     let wrapper = match T.wrapper with
       | None -> None
       | Some w -> Some (trbl_ocf_wrapper w)
     let transition = Option.map trbl_transition T.transition
   end)
module PTrbl_int = PTrbl(TInt)
module PTrbl_color = PTrbl(TColor)


let list_transition f ~start ~stop r =
  List.map2 (fun start stop -> f ~start ~stop r) start stop

module PList (T:PT) =
  Add_prop_type(struct
     type t = T.t list
     let compare = List.compare T.compare
     let wrapper = match T.wrapper with
       | None -> None
       | Some w -> Some (Ocf.Wrapper.list w)
     let transition = Option.map list_transition T.transition
   end)

module PPair (T1:PT) (T2:PT) =
  Add_prop_type(struct
     type t = T1.t * T2.t
     let compare (a1,b1) (a2,b2) =
       match T1.compare a1 a2 with
       | 0 -> T2.compare b1 b2
       | n -> n
     let wrapper = match T1.wrapper with
       | None -> None
       | Some w1 ->
           match T2.wrapper with
           | None -> None
           | Some w2 -> Some (Ocf.Wrapper.pair w1 w2)
     let transition =
       match T1.transition, T2.transition with
       | None, None -> None
       | Some f, None -> Some
           (fun ~start:(a1,_) ~stop:(a2,b2) r -> f ~start:a1 ~stop:a2 r, b2)
       | None, Some f -> Some
           (fun ~start:(_,b1) ~stop:(a2,b2) r -> a2, f ~start:b1 ~stop:b2 r)
       | Some f1, Some f2 -> Some
           (fun ~start:(a1,b1) ~stop:(a2,b2) r ->
              (f1 ~start:a1 ~stop:a2 r, f2 ~start:b1 ~stop:b2 r))
   end)
module PTriple (T1:PT) (T2:PT) (T3:PT) =
  Add_prop_type(struct
     type t = T1.t * T2.t * T3.t
     let compare (a1,b1,c1) (a2,b2,c2) =
       match T1.compare a1 a2 with
       | 0 ->
           (match T2.compare b1 b2 with
            | 0 -> T3.compare c1 c2
            | n -> n
           )
       | n -> n
     let wrapper =
       match T1.wrapper with
       | None -> None
       | Some w1 ->
           match T2.wrapper with
           | None -> None
           | Some w2 ->
               match T3.wrapper with
               | None -> None
               | Some w3 -> Some (Ocf.Wrapper.triple w1 w2 w3)

     let transition =
       match T1.transition, T2.transition, T3.transition with
       | None, None, None -> None
       | Some f, None, None -> Some
           (fun ~start:(a1,_,_) ~stop:(a2,b2,c2) r -> f ~start:a1 ~stop:a2 r, b2, c2)
       | None, Some f, None -> Some
           (fun ~start:(_,b1,_) ~stop:(a2,b2,c2) r -> a2, f ~start:b1 ~stop:b2 r, c2)
       | None, None, Some f -> Some
           (fun ~start:(_,_,c1) ~stop:(a2,b2,c2) r -> a2, b2, f ~start:c1 ~stop:c2 r)
       | Some f1, Some f2, None -> Some
           (fun ~start:(a1,b1,_) ~stop:(a2,b2,c2) r ->
              (f1 ~start:a1 ~stop:a2 r, f2 ~start:b1 ~stop:b2 r, c2))
       | Some f1, None, Some f3 -> Some
           (fun ~start:(a1,_,c1) ~stop:(a2,b2,c2) r ->
              (f1 ~start:a1 ~stop:a2 r, b2, f3 ~start:c1 ~stop:c2 r))
       | None, Some f2, Some f3 -> Some
           (fun ~start:(_,b1,c1) ~stop:(a2,b2,c2) r ->
              (a2, f2 ~start:b1 ~stop:b2 r, f3 ~start:c1 ~stop:c2 r))
       | Some f1, Some f2, Some f3 -> Some
           (fun ~start:(a1,b1,c1) ~stop:(a2,b2,c2) r ->
              (f1 ~start:a1 ~stop:a2 r, f2 ~start:b1 ~stop:b2 r, f3 ~start:c1 ~stop:c2 r))
   end)

module PPair_float = PPair(PFloat)(PFloat)

let int_prop = PInt.mk_prop
let float_prop = PFloat.mk_prop
let color_prop = PColor.mk_prop
let bool_prop = PBool.mk_prop
let string_prop = PString.mk_prop
let uchar_prop = PUchar.mk_prop
let font_desc_prop = PFont_desc.mk_prop

let int_trbl_prop = PTrbl_int.mk_prop

let color_trbl_prop = PTrbl_color.mk_prop

let float_pair_prop = PPair_float.mk_prop

let props_prop = PProps.mk_prop

let keystate_prop = PKeystate.mk_prop

type text_valign =
| Baseline
| Sub
| Super
| Top
| Text_top
| Middle
| Bottom
| Text_bottom
let string_of_text_valign = function
| Baseline -> "baseline"
| Sub -> "sub"
| Super -> "super"
| Top -> "top"
| Text_top -> "text_top"
| Middle -> "middle"
| Bottom -> "bottom"
| Text_bottom -> "text_bottom"
let text_valign_of_string s =
  match String.lowercase_ascii s with
  | "baseline" -> Baseline
  | "sub" -> Sub
  | "super" -> Super
  | "top" -> Top
  | "text-top" -> Text_top
  | "middle" -> Middle
  | "bottom" -> Bottom
  | "text-bottom" -> Text_bottom
  | _ ->
      Log.warn (fun m -> m "invalid text_valign value %S; defaulting to baseline" s);
      Baseline
let text_valign_wrapper =
  let to_json ?with_doc m = `String (string_of_text_valign m) in
  let from_json ?def = function
  | `String s -> text_valign_of_string s
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json
module TText_valign = struct
    type t = text_valign
    let compare = Stdlib.compare
    let wrapper = Some text_valign_wrapper
    let transition = None
  end
module PText_valign = Add_prop_type(TText_valign)
let text_valign = PText_valign.mk_prop
  ~default:Baseline
  ~inherited:false "text_valign"

type selection_mode =
| Sel_none
| Sel_single
| Sel_browse
| Sel_multiple

let string_of_selection_mode = function
| Sel_none -> "none"
| Sel_single -> "single"
| Sel_browse -> "browse"
| Sel_multiple -> "multiple"

let selection_mode_of_string s =
  match String.lowercase_ascii s with
  | "none" -> Sel_none
  | "single" -> Sel_single
  | "browse" -> Sel_browse
  | "multiple" -> Sel_multiple
  | _ ->
      Log.warn (fun m -> m "invalid selection_mode %S; defaulting to Sel_multiple" s);
      Sel_multiple

let selection_mode_wrapper =
  let to_json ?with_doc m = `String (string_of_selection_mode m) in
  let from_json ?def = function
  | `String s -> selection_mode_of_string s
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

module TSel_mode = struct
    type t = selection_mode
    let compare = Stdlib.compare
    let wrapper = Some selection_mode_wrapper
    let transition = None
  end
module PSel_mode = Add_prop_type(TSel_mode)
let selection_mode = PSel_mode.mk_prop
  ~default:Sel_multiple
  ~inherited:false "selection_mode"

type orientation = Vertical | Horizontal

let string_of_orientation = function
| Vertical -> "vertical"
| Horizontal -> "horizontal"

let orientation_of_string s =
  match String.lowercase_ascii s with
  | "vertical" -> Vertical
  | "horizontal" -> Horizontal
  | _ ->
      Log.warn (fun m -> m "invalid orientation %S; defaulting to Vertical" s);
      Vertical

let orientation_wrapper =
  let to_json ?with_doc m = `String (string_of_orientation m) in
  let from_json ?def = function
  | `String s -> orientation_of_string s
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

module TOrientation = struct
    type t = orientation
    let compare = Stdlib.compare
    let wrapper = Some orientation_wrapper
    let transition = None
  end
module POrientation = Add_prop_type(TOrientation)

let orientation = POrientation.mk_prop ~after:[Resize]
  ~default:Vertical
  ~inherited:false "orientation"

let pp_prop : 'a prop -> Format.formatter -> 'a -> unit=
  fun p ->
  let module P = (val get_prop p : Prop) in
  fun ppf v ->
    let to_string = prop_to_string p in
    Format.pp_print_string ppf (to_string v)

let to_string t =
  let l = Map.fold (fun id (v:prop_value) -> fun acc ->
       let p = get_prop id in
       let module P = (val p : Prop) in
       let str = Printf.sprintf "%s: %s" P.name
         (prop_to_string id (P.from_prop_value v))
       in
       str :: acc) t.t []
  in
  String.concat ", " l

let pp ppf t =
  Format.pp_open_box ppf 0;
  Map.iter (fun id (v:prop_value) ->
     let p = get_prop id in
     let module P = (val p : Prop) in
     Format.fprintf ppf "%s: %s,@," P.name
       (prop_to_string id (P.from_prop_value v))
  ) t.t;
  Format.pp_close_box ppf ()

let dup t = { t = t.t }

let merge =
  let f use_inherited k v1 v2 =
    match v1, v2 with
    | None, None -> None
    | None, Some _ -> v2
    | Some _, None when use_inherited ->
        let module P = (val get_prop k : Prop) in
        if P.inherited then v1 else None
    | Some _, None -> v1
    | Some _, Some _ -> v2
  in
  fun ?(use_inherited=false) t1 t2 ->
    { t = Map.merge (f use_inherited) t1.t t2.t }

let opt : t -> 'a prop -> 'a option =
  fun t id ->
    match Map.find_opt id t.t with
    | None -> None
    | Some (v:prop_value) -> Some (from_prop_value id v)

let get : t -> 'a prop -> 'a =
  fun t id ->
    match opt t id with
    | Some v -> v
    | None ->
        let module P = (val get_prop id : Prop) in
        match P.default with
        | Some v -> Obj.magic (*allow P.t to escape*) v
        | None -> Misc.missing_prop P.name (to_string t)

type props = t

let padding = int_trbl_prop ~inherited:false ~after:[Resize] ~default:(trbl__ 0) "padding"
let margin = int_trbl_prop ~inherited:false ~after:[Resize] ~default:(trbl__ 0) "margin"
let border_width = int_trbl_prop ~inherited:false ~after:[Resize] ~default:(trbl__ 0) "border_width"
let border_color = color_trbl_prop ~inherited:false
  ~after:[Render] ~default:(trbl__ Color.transparent) "border_color"
let border_color_hover = color_trbl_prop ~inherited:false
  ~after:[Render] ~default:(trbl__ Color.transparent) "border_color_hover"
let border_color_selected = color_trbl_prop ~inherited:false
  ~after:[Render] ~default:(trbl__ Color.transparent) "border_color_selected"
let border_color_focused = color_trbl_prop ~inherited:false
  ~after:[Render] ~default:(trbl__ Color.transparent) "border_color_focused"

let active = bool_prop ~after:[Render] ~default:false ~inherited:false "active"

(*
let margin_left = int_prop "margin_left"
let margin_right = int_prop "margin_right"
let margin_top = int_prop "margin_top"
let margin_bottom = int_prop "margin_bottom"
*)

let hexpand = int_prop ~after:[Resize]
  ~inherited:false ~default:1 "hexpand"
let vexpand = int_prop ~after:[Resize]
  ~inherited:false ~default:1 "vexpand"

let visible = bool_prop ~inherited:false
  ~after:[Resize] ~default:true "visible"

let sensitive = bool_prop ~inherited:false
  ~after:[Render] ~default:true "sensitive"
let insensitive_color_mask = color_prop ~after:[Render]
  ~default: 0x80808044l "insensitive_color_mask"

let hfill = bool_prop ~after:[Resize]
  ~inherited:false ~default:true "hfill"
let vfill = bool_prop ~after:[Resize]
  ~inherited:false ~default:true "vfill"

let halign = float_prop ~after:[Render] ~default:0.5 "halign"
let valign = float_prop ~after:[Render] ~default:0.5 "valign"

let width = int_prop ~after:[Resize] "width"
let height = int_prop ~after:[Resize] "height"

let max_width = int_prop ~after:[Resize] "max_width"
let max_height = int_prop ~after:[Resize] "max_height"

let fill = bool_prop ~after:[Render] ~inherited:false ~default:false "fill"
let bg_fill_borders = bool_prop ~after:[Render]
  ~inherited:false ~default:false "bg_fill_borders"

let font_desc = font_desc_prop ~after:[Resize]
  ~default:(Font.font_desc ~size:14 "DejaVu Sans") "font_desc"

let bold = bool_prop ~after:[Resize] "bold"
let italic = bool_prop ~after:[Resize] "italic"

let fg_color = color_prop ~after:[Render]
  ~default:0x333333ffl "fg_color"
let fg_color_hover = color_prop ~after:[Render]
  ~default:0xdd2222ffl "fg_color_hover"
let fg_color_selected = color_prop ~after:[Render]
  ~default:0x444444ffl "fg_color_selected"
let fg_color_focused = color_prop ~after:[Render] "fg_color_focused"

let bg_color = color_prop ~after:[Render] ~inherited:false
  ~default:Color.transparent "bg_color"
let bg_color_hover = color_prop ~after:[Render] ~inherited:false
  ~default:0xaabbbbffl "bg_color_hover"
let bg_color_selected = color_prop ~after:[Render] ~inherited:false
  ~default:0x2222ddffl "bg_color_selected"
let bg_color_focused = color_prop ~after:[Render] ~inherited:false "bg_color_focused"

let selection_fg_color = color_prop ~after:[Render]
  ~default:0x444444ffl "selection_fg_color"
let selection_bg_color = color_prop ~after:[Render]
  ~default:0x2222ddffl "selection_bg_color"

let input_bg_color = color_prop ~after:[Render]
  ~default:0xeeeeeeffl "input_bg_color"
let input_ghost_color = color_prop ~after:[Render]
  ~default:0xccccccffl "input_ghost_color"

let opacity = float_prop ~after:[Render] "opacity"

let current_line_bg_color = color_prop
  ~after:[Render] "current_line_bg_color"

let click_mask = color_prop ~after:[Render]
  ~default:0xffffff88l "click_mask"

(* Widget has the global input focus, i.e. its window
  has the global input focus and the widget has
  its is_focus property set to true. *)
let has_focus = bool_prop
  ~inherited:false
  ~after:[
    Action (fun b ->
       if b
       then Tsdl.Sdl.start_text_input ()
       else Tsdl.Sdl.stop_text_input ()) ;
    Render] ~default:false "has_focus"

let is_focus = bool_prop ~after:[Render] ~default:false ~inherited:false "is_focus"

let focusable = bool_prop ~inherited:false ~default:false "focusable"

let can_focus = bool_prop ~inherited:false ~default:true "can_focus"

let show_on_focus = bool_prop ~inherited:false ~default:true "show_on_focus"

let selected = bool_prop ~after:[Render] ~default:false ~inherited:false "selected"

let text = string_prop ~after:[Resize] "text"
let glyph = int_prop ~after:[Resize] "glyph"
let ghost_text = string_prop ~after:[Render] "ghost_text"

let editable = bool_prop ~inherited:false ~default:true "editable"

let cursor_width = int_prop ~default:2 ~after:[Render] "cursor_width"
let cursor_color = color_prop ~default:Color.red ~after:[Render] "cursor_color"
let active_cursor_color = color_prop ~default:Color.red ~after:[Render] "active_cursor_color"

let scrollbar_width = int_prop ~default:12 "scrollbar_width"
let scrollbar_handle_min_size = int_prop ~default: 40 "scrollbar_handle_min_size"
let scrollbar_handle_color = color_prop
  ~default:0x2222dd00l "scrollbar_handle_color"
let scrollbar_bg_color = color_prop
  ~default:0xaaaaff99l "scrollbar_bg_color"

let get_font props =
  let desc = get props font_desc in
  let desc = match opt props bold with
    | None -> desc
    | Some bold -> { desc with Font.bold }
  in
  let desc = match opt props italic with
    | None -> desc
    | Some italic -> { desc with italic }
  in
  Font.get desc

let get_font_for_char props c =
  let fn = get_font props in
  let code = Uchar.to_int c in
  if Font.glyph_is_provided fn code then
    fn
  else
    match Font.fallback_font code with
    | None ->
        [%debug "get_font_for_char %x: no fallback font" code];
        fn
    | Some family ->
        [%debug "get_font_for_char %x" code];
        let desc = get props font_desc in
        try Font.get { desc with family }
        with e ->
          [%debug "Props.get_font_for_char %x: %s"
               code (Printexc.to_string e)];
            fn

let set_font_size p size =
  let d = get p font_desc in
  set p font_desc { d with Font.size }

let set_font_italic p italic =
  let d = get p font_desc in
  set p font_desc { d with Font.italic }

let set_font_bold p bold =
  let d = get p font_desc in
  set p font_desc { d with Font.bold }

let set_font_family p family =
  let d = get p font_desc in
  set p font_desc { d with Font.family }

let set_font_underline p underline =
  let d = get p font_desc in
  set p font_desc { d with Font.underline }

let set_font_strikethrough p strikethrough =
  let d = get p font_desc in
  set p font_desc { d with Font.strikethrough }

let set_font_kerning p kerning =
  let d = get p font_desc in
  set p font_desc { d with Font.kerning }

let set_font_outline p outline =
  let d = get p font_desc in
  set p font_desc { d with Font.outline }

let update : t -> 'a prop -> 'a -> 'a option option =
  fun t p v ->
  match Map.find_opt p t.t with
  | None ->
      set t p v;
      Some None
  | Some (v0 : prop_value) ->
      let module P = (val get_prop p) in
      let v0 = P.from_prop_value v0 in
      if P.compare v0 (Obj.magic v) = 0 then
        None
      else
        (
         set t p v;
         Some (Some (Obj.magic v0 : 'a))
        )

let clear t = t.t <- Map.empty

let default = let p = empty () in p

open Misc

let create () =
  let t = dup default in
  t

let fold_registered_properties :
  (?default:'a -> 'a prop -> 'acc -> 'acc) -> 'acc -> 'acc =
    fun (f:?default:'a -> 'a prop -> 'acc -> 'acc) acc ->
      Array.fold_right
        (fun (module P:Prop) acc ->
           let default = default_value P.id in
           f ?default P.id acc
        )
        !props acc

let iter : ('a prop -> 'a -> unit) -> t -> unit =
  fun (f:'a prop -> 'a -> unit) p ->
    let g p v = f p (from_prop_value p v)
    in
    Map.iter g p.t

let fold : ('a prop -> 'a -> 'acc -> 'acc) -> t -> 'acc -> 'acc =
  fun (f:'a prop -> 'a -> 'acc -> 'acc) p acc ->
    let g p v acc = f p (from_prop_value p v) acc  in
    Map.fold g p.t acc

let to_json : t -> Yojson.Safe.t =
  fun t ->
  `Assoc (fold
    (fun p v acc ->
      let module P = (val get_prop p : Prop) in
      match P.wrapper with
      | None -> acc
      | Some w -> (P.name, w.to_json (Obj.magic v)) :: acc)
     t [])