Reactive properties and styles

lib/brr-lwd/elwd.ml

@@ -175,56 +175,96 @@ let update_children
 
 let pure_unit = Lwd.pure ()
 
-let dummy_kv_at = (Jstr.empty, Jstr.empty)
+type 'a kv = {
+  unset_kv : 'a -> El.t -> unit;
+  set_kv : ?old:'a -> 'a -> El.t -> unit;
+  dummy_kv : 'a;
+}
 
-let attach_attribs el attribs =
-  let set_kv (k, v) =
+let attr_kv =
+  let set_kv (k, v) el =
     if Jstr.equal k At.Name.class'
     then El.set_class v true el
     else El.set_at k (Some v) el
   in
-  let unset_kv (k, v) =
+  let unset_kv (k, v) el =
     if Jstr.equal k At.Name.class'
     then El.set_class v false el
     else El.set_at k None el
   in
+  let reset_kv ((old_k, _) as old) (k, v) el =
+    let requires_unsetting =
+      not (Jstr.equal old_k k) || Jstr.equal old_k At.Name.class'
+    in
+    if requires_unsetting then
+      unset_kv old el;
+    set_kv (k, v) el
+  in
+  let set_kv ?old kv el =
+    let kv = At.to_pair kv in
+    let old = Option.map At.to_pair old in
+    match old with None -> set_kv kv el | Some old -> reset_kv old kv el
+  in
+  let unset_kv at el =
+    let kv = At.to_pair at in
+    unset_kv kv el
+  in
+  let dummy_kv = At.v Jstr.empty Jstr.empty in
+  { unset_kv; set_kv; dummy_kv }
+
+let style_kv =
+  let unset_kv (k,_) el =
+    El.remove_inline_style k el
+  in
+  let set_kv ?old (k,v) el =
+    let () =
+      Option.iter (fun ((old_k, _) as old) ->
+          if not (Jstr.equal old_k k) then unset_kv old el)
+        old
+    in
+    El.set_inline_style k v el
+  in
+  let dummy_kv = (Jstr.empty, Jstr.empty) in
+  { unset_kv; set_kv; dummy_kv }
+
+let attach_kv {set_kv; unset_kv; dummy_kv} el attribs =
   let set_lwd_at () =
-    let prev = ref dummy_kv_at in
+    let prev = ref dummy_kv in
     fun at ->
-      if !prev != dummy_kv_at then
-        unset_kv !prev;
-      let pair = At.to_pair at in
-      set_kv pair;
-      prev := pair
+      set_kv ~old:!prev at el;
+      prev := at
   in
   Lwd_utils.map_reduce (function
       | `P _ -> assert false
       | `R at -> Lwd.map ~f:(set_lwd_at ()) at
       | `S ats ->
-        let set_at' at =
-          let kv = At.to_pair at in
-          set_kv kv;
+        let set_kv kv =
+          set_kv kv el;
           kv
         in
         let reducer =
           ref (Lwd_seq.Reducer.make
-                 ~map:set_at'
-                 ~reduce:(fun _ _ -> dummy_kv_at))
+                 ~map:set_kv
+                 ~reduce:(fun _ _ -> dummy_kv))
         in
         let update ats =
           let dropped, reducer' =
             Lwd_seq.Reducer.update_and_get_dropped !reducer ats
           in
           reducer := reducer';
           Lwd_seq.Reducer.fold_dropped `Map
-            (fun kv () -> unset_kv kv)
+            (fun kv () -> unset_kv kv el)
             dropped ();
           ignore (Lwd_seq.Reducer.reduce reducer': _ option)
         in
         Lwd.map ~f:update ats
     ) (pure_unit, Lwd.map2 ~f:(fun () () -> ()))
     attribs
 
+let attach_attribs = attach_kv attr_kv
+
+let attach_styles = attach_kv style_kv
+
 let listen el (Handler {opts; type'; func}) =
   Ev.listen ?opts type' func (El.as_target el)
 
@@ -260,46 +300,53 @@ let attach_events el events =
     ) (pure_unit, Lwd.map2 ~f:(fun () () -> ()))
     events
 
-let v ?d ?(at=[]) ?(ev=[]) tag children =
+let v ?d ?(at=[]) ?(ev=[]) ?(st=[]) tag children =
   let at, impure_at = prepare_col at in
   let ev, impure_ev = prepare_col ev in
+  let st, impure_st = prepare_col st in
   let children, impure_children = consume_children children in
   let el = El.v ?d ~at tag children in
   let result =
-    match impure_at, impure_children with
-    | [], None -> Lwd.pure el
-    | [], Some children ->
-      update_children el children
-    | at, None ->
-      Lwd.map ~f:(fun () -> el) (attach_attribs el at)
-    | at, Some children ->
-      Lwd.map2 ~f:(fun () el -> el)
-        (attach_attribs el at)
-        (update_children el children)
+    match impure_children with
+    | None -> Lwd.pure el
+    | Some children -> update_children el children
   in
-  List.iter (fun h -> ignore (listen el h)) ev;
-  let result =
-    match impure_ev with
+  let attach_impure attach impure result =
+    match impure with
     | [] -> result
-    | evs ->
-      Lwd.map2 ~f:(fun () el -> el)
-        (attach_events el evs)
-        result
+    | impure -> Lwd.map2 ~f:(fun () el -> el) (attach el impure) result
   in
+  let result = attach_impure attach_attribs impure_at result in
+  List.iter (fun h -> ignore (listen el h)) ev;
+  let result = attach_impure attach_events impure_ev result in
+  let result = attach_impure attach_styles impure_st result in
+  List.iter (fun kv -> style_kv.set_kv kv el) st;
   result
 
 (** {1:els Element constructors} *)
 
-type cons =  ?d:document -> ?at:At.t col -> ?ev:handler col -> t col -> t Lwd.t
+type cons =
+  ?d:document ->
+  ?at:At.t col ->
+  ?ev:handler col ->
+  ?st:(El.Style.prop * Jstr.t) col ->
+  t col ->
+  t Lwd.t
 (** The type for element constructors. This is simply {!v} with a
     pre-applied element name. *)
 
-type void_cons = ?d:document -> ?at:At.t col -> ?ev:handler col -> unit -> t Lwd.t
+type void_cons =
+  ?d:document ->
+  ?at:At.t col ->
+  ?ev:handler col ->
+  ?st:(El.Style.prop * Jstr.t) col ->
+  unit ->
+  t Lwd.t
 (** The type for void element constructors. This is simply {!v}
     with a pre-applied element name and without children. *)
 
-let cons name ?d ?at ?ev cs = v ?d ?at ?ev name cs
-let void_cons name ?d ?at ?ev () = v ?d ?at ?ev name []
+let cons name ?d ?at ?ev ?st cs = v ?d ?at ?ev ?st name cs
+let void_cons name ?d ?at ?ev ?st () = v ?d ?at ?ev ?st name []
 
 let a = cons Name.a
 let abbr = cons Name.abbr

lib/brr-lwd/elwd.mli

@@ -16,7 +16,14 @@ type 'a col = [
 type handler (* An event handler *)
 val handler : ?opts:Ev.listen_opts -> 'a Ev.type' -> ('a Ev.t -> unit) -> handler
 
-val v : ?d:document -> ?at:At.t col -> ?ev:handler col -> tag_name -> t col -> t Lwd.t
+val v :
+  ?d:document ->
+  ?at:At.t col ->
+  ?ev:handler col ->
+  ?st:(El.Style.prop * Jstr.t) col ->
+  tag_name ->
+  t col ->
+  t Lwd.t
 (** [v ?d ?at name cs] is an element [name] with attribute [at]
     (defaults to [[]]) and children [cs]. If [at] specifies an
     attribute more thanonce, the last one takes over with the
@@ -26,11 +33,23 @@ val v : ?d:document -> ?at:At.t col -> ?ev:handler col -> tag_name -> t col -> t
 
 (** {1:els Element constructors} *)
 
-type cons =  ?d:document -> ?at:At.t col -> ?ev:handler col -> t col -> t Lwd.t
+type cons =
+  ?d:document ->
+  ?at:At.t col ->
+  ?ev:handler col ->
+  ?st:(El.Style.prop * Jstr.t) col ->
+  t col ->
+  t Lwd.t
 (** The type for element constructors. This is simply {!v} with a
     pre-applied element name. *)
 
-type void_cons = ?d:document -> ?at:At.t col -> ?ev:handler col -> unit -> t Lwd.t
+type void_cons =
+  ?d:document ->
+  ?at:At.t col ->
+  ?ev:handler col ->
+  ?st:(El.Style.prop * Jstr.t) col ->
+  unit ->
+  t Lwd.t
 (** The type for void element constructors. This is simply {!v}
     with a pre-applied element name and without children. *)