Source file theme.ml

open Misc

type t = {
    name : string ;
    mutable classes : Props.t SMap.t ;
    mutable variables : Yojson.Safe.t SMap.t ;
  }

let variables t = t.variables

let themes = ref SMap.empty
let get_or_create name =
  match SMap.find_opt name !themes with
  | None ->
      let t = { name ; classes = SMap.empty ; variables = SMap.empty } in
      themes := SMap.add name t !themes;
      t
  | Some t -> t

let current = ref (get_or_create "default")
let set_current t = current := t
let current () = !current

let default_json = Yojson.Safe.from_string [%blob "default_theme.json"]

let int32_wrapper =
  let to_j ?with_doc n = `Int (Int32.to_int n) in
  let from_j ?def = function
    `Int n -> Int32.of_int n
  | (`Intlit s)
  | (`String s) as json ->
      begin
        try Int32.of_int (int_of_string s)
        with _ -> Ocf.invalid_value json
      end
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_j from_j

let apply_inherit smap props str =
  match SMap.find_opt str smap with
  | None ->
      Log.warn (fun m -> m "Class %S not found for inheritage" str);
      props
  | Some p -> Props.merge props p

let apply_inherits smap p names =
  List.fold_left (apply_inherit smap) p names

let add_class t name json =
  let p =
    match SMap.find_opt name t.classes with
    | None -> Props.empty ()
    | Some p ->
      Log.warn (fun m -> m "extending props of class %S" name);
       p
  in
  let p =
    match json with
    | `Assoc l ->
        (
         match List.assoc_opt "inherits" l with
         | Some (`String s) -> apply_inherit t.classes p s
         | Some (`List l) ->
             List.fold_left (fun acc -> function
                | `String s -> apply_inherit t.classes acc s | _ -> acc)
               p l
         | _ -> p
        )
    | _ -> p
  in
  Props.set_from_json ~vars:t.variables p json ;
  Log.info (fun m -> m "Theme: adding class %S: %a" name
    Props.pp p);
  t.classes <- SMap.add name p t.classes

let add_def t (name,json) =
  match Props.var_of_string name with
  | Some v -> t.variables <- SMap.add v json t.variables
  | None -> add_class t name json

let add_defs t assocs = List.iter (add_def t) assocs

let load_theme name json =
  match json with
  | `Assoc l ->
      let t = get_or_create name in
      add_defs t l
  | _ ->
      Ocf.invalid_value json

let to_json t =
  `Assoc
    (SMap.fold (fun name props acc ->
      (name, Props.to_json props) :: acc) t.classes [])

let to_string t =
  Yojson.Safe.pretty_to_string (to_json t)

let add_class ?(inherits=[]) name props =
  let t = current () in
  let props = apply_inherits t.classes props inherits in
  t.classes <- Misc.SMap.add name props t.classes

let extend_current_from_json = function
| `Assoc l -> add_defs (current()) l
| json -> Ocf.invalid_value json

let of_class ?name cls =
  let t = current () in
  let p =
    match SMap.find_opt cls t.classes with
    | None ->
        Log.warn (fun m -> m "No props found for class %S" cls);
        Props.(dup default)
    | Some p ->
        Log.debug (fun m -> m "Props for %S: %a"
          cls Props.pp p);
        Props.merge Props.default p
  in
  match name with
  | None -> p
  | Some name ->
      match SMap.find_opt name t.classes with
      | None ->
          Log.debug (fun m -> m "No props found for name %S" name);
          p
      | Some p2 -> Props.merge p p2

let init () = load_theme "default" (default_json)