Vdom in OCaml

vdom.ml

module StringLike = struct
  type t = string

  let of_string : string -> t = fun s -> String.lowercase s
  let to_string : t -> string = fun s -> s
  let compare : t -> t -> int = String.compare
end

module Tag = struct
  include StringLike
end

module Class = struct
  include StringLike
  module Set = Set.Make (String)
end

module Style = struct
  include StringLike
  module Map = Map.Make (String)
  module Value = String
end

module Key = struct
  include StringLike
end

module HtmlValue = struct
  type t =
    [ `String of string
    | `Int    of int
    | `Float  of float
    | `Bool   of bool
    ]

  let of_string s = `String s
  let of_int i    = `Int i
  let of_float f  = `Float f
  let of_bool b   = `Bool b
end

module Attr = struct
  include StringLike
  module Map = Map.Make (String)
  module Value = HtmlValue
end

module Source = struct
  include StringLike
  module Map = Map.Make (String)
end

module Event = struct
  type t = unit
end

module Lens = struct
  type (-'s, +'t, +'a, -'b) t =
    { view : 's -> 'a
    ; over : ('a -> 'b) -> ('s -> 't)
    }

  type ('s, 'a) t' = ('s, 's, 'a, 'a) t

  let view lens s   = lens.view s
  let over lens f s = lens.over f s
  let set  lens b s = lens.over (fun _ -> b) s

  let make get set = { view = get; over = fun f s -> set s (f (get s)) }
end

module El = struct
  type t =
    { tag       : Tag.t
    ; key       : Key.t option
    ; id        : string option
    ; classes   : Class.Set.t
    ; styles    : Style.Value.t Style.Map.t
    ; attrs     : Attr.Value.t Attr.Map.t
    ; listeners : (Event.t -> unit) Source.Map.t
    }

  let _tag       = Lens.make (fun el -> el.tag) (fun el tag -> {el with tag = tag})
  let _key       = Lens.make (fun el -> el.key) (fun el key -> {el with key = key})
  let _id        = Lens.make (fun el -> el.id) (fun el id -> {el with id = id})
  let _classes   = Lens.make (fun el -> el.classes) (fun el classes -> {el with classes = classes})
  let _styles    = Lens.make (fun el -> el.styles) (fun el styles -> {el with styles = styles})
  let _attrs     = Lens.make (fun el -> el.attrs) (fun el attrs -> {el with attrs = attrs})
  let _listeners = Lens.make (fun el -> el.listeners) (fun el listeners -> {el with listeners = listeners})
end

module VTree = struct

  type 'x spec =
    | Node of El.t * 'x array
    | Text of string

  let map f = function
    | Node (el, chl) -> Node (el, Array.map f chl)
    | Text s -> Text s

  type t = T of t spec

  let dn (T t) = t
  let up t = (T t)


  let text (s : string) : t = up (Text s)
  let node tag props children : t =
    let open El in
    let el0 =
      { tag       = Tag.of_string tag
      ; key       = None
      ; id        = None
      ; classes   = Class.Set.empty
      ; styles    = Style.Map.empty
      ; attrs     = Attr.Map.empty
      ; listeners = Source.Map.empty
      } in
    let folder el = function
      | `Id i            -> Lens.set _id (Some i) el
      | `Key k           -> Lens.set _key (Some k) el
      | `Class c         -> Lens.over _classes (Class.Set.add c) el
      | `Style (k, v)    -> Lens.over _styles (Style.Map.add k v) el
      | `Attr (k, v)     -> Lens.over _attrs (Attr.Map.add k v) el
      | `Listener (s, h) -> Lens.over _listeners (Source.Map.add s h) el
    in
    let elF = List.fold_left folder el0 props in
    up (Node (elF, Array.of_list children))

end