init

Author: art-w

.gitignore

@@ -0,0 +1,20 @@
+*.annot
+*.cmo
+*.cma
+*.cmi
+*.a
+*.o
+*.cmx
+*.cmxs
+*.cmxa
+
+.merlin
+*.install
+*.coverage
+*.sw[a-z]
+
+_build/
+_doc/
+_coverage/
+_opam/
+playground/codemirror/

.ocamlformat

@@ -0,0 +1,4 @@
+profile = janestreet
+let-binding-spacing = compact
+sequence-style = separator
+doc-comments = after-when-possible

LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2022 Arthur Wendling
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

README.md

@@ -0,0 +1,7 @@
+Can GUI programming be purely functional? This library demonstrates a small algebra of 7 combinators with intuitive laws to make GUI programming super concise, declarative, easy to reason and efficient to use. It's a bold claim! As the humble name of this library suggests, I'm too biased to be trusted. You will have to judge by yourself if it delivers:
+
+[**Try the interactive online tutorial**](https://art-w.github.io/unicorn/playground.html) | [**Documentation**](https://art-w.github.io/unicorn/unicorn_jsoo/Unicorn_jsoo/index.html)
+
+This is a very early release focused on showing off the combinators API. A lot of features and optimizations are still missing for real world usage! Bugs are expected. You will get the most of it if you enjoy playing with weird new toys... or if you have an interest in the theoretical questions: How can widgets have internal state but also be referentially transparent?  What does it mean to "move" a pure widget? Can we do reactive GUIs without FRP or monads?
+
+Unicorn took years of inspiration from previous works, ranging from the immediate mode community to the most hardcore of Haskell's "Arrowized FRP" GUIs. It should look familiar at first -- but different choices allow it to sidestep the complexity and the semantic hacks. The `dynamic` value turns this API into a different beast, one that has as much to teach us as it is avid on learning purely functional tricks. I'm still discovering new ideas and having fun, so I hope you will also find something cool in there. Get in touch if you do!

dune-project

@@ -0,0 +1,31 @@
+(lang dune 2.8)
+(generate_opam_files true)
+
+(name unicorn)
+(source (github art-w/unicorn))
+(license MIT)
+(authors "Arthur Wendling")
+(maintainers "[email protected]")
+(version 0.1)
+
+(package
+  (name unicorn_jsoo)
+  (synopsis "Purely functional GUI library (js_of_ocaml backend)")
+  (depends
+    (ocaml (>= "4.12.0"))
+    js_of_ocaml
+    optic))
+
+(package
+  (name optic)
+  (synopsis "Isomorphisms, lenses and prisms")
+  (depends
+    (ocaml (>= "4.08"))))
+
+(package
+  (name ppx_deriving_optic)
+  (synopsis "PPX deriver for lenses and prisms")
+  (depends
+    (ocaml (>= "4.08"))
+    ppxlib
+    ppx_deriving))

jsoo/algebra.ml

@@ -0,0 +1,147 @@
+open Optic
+open Type
+
+type 'a t = 'a Type.t
+
+let empty : type a. a t = W ((), (), Eq.unit, fun x -> x, Dag.empty ())
+
+let ( & ) (W (c0, s0, _, w0)) (W (c1, s1, _, w1)) =
+  W
+    ( (None, c0, c1)
+    , (s0, s1)
+    , Eq.create ()
+    , fun ((x, (s0, s1), (cache, c0, c1)) as input) ->
+        match cache with
+        | Some (x', s0', s1', img) when x == x' && s0 == s0' && s1 == s1' -> input, img
+        | _ ->
+          let (x, s0, c0), img0 = w0 (x, s0, c0) in
+          let (x, s1, c1), img1 = w1 (x, s1, c1) in
+          let img = Dag.seq img0 img1 in
+          let cache = Some (x, s0, s1, img) in
+          (x, (s0, s1), (cache, c0, c1)), img )
+
+let iso iso (W (c, s, _, w)) =
+  let iso' =
+    { Iso.ltor = (fun (x, y) -> Iso.ltor iso x, y)
+    ; rtol = (fun (x, y) -> Iso.rtol iso x, y)
+    }
+  in
+  let eq_iso = Eq.create () in
+  W
+    ( (None, c)
+    , s
+    , Eq.create ()
+    , fun ((x, s, (cache, c)) as input) ->
+        match cache with
+        | Some (x', s', img) when x == x' && s == s' -> input, img
+        | _ ->
+          let y = Optic.Iso.ltor iso x in
+          let (y, s, c), img = w (y, s, c) in
+          let x = Optic.Iso.rtol iso y in
+          let img = Dag.iso eq_iso iso' img in
+          let cache = Some (x, s, img) in
+          (x, s, (cache, c)), img )
+
+let on lens (W (c, s, _, w)) =
+  let eq_lens = Eq.create () in
+  W
+    ( (None, c)
+    , s
+    , Eq.create ()
+    , fun ((x, s, (cache, c)) as input) ->
+        match cache with
+        | Some (x', s', img) when x == x' && s == s' -> input, img
+        | _ ->
+          let y = Optic.Lens.get lens x in
+          let (y, s, c), img = w (y, s, c) in
+          let x = Optic.Lens.put lens y x in
+          let img = Dag.on eq_lens lens img in
+          let cache = Some (x, s, img) in
+          (x, s, (cache, c)), img )
+
+let into prism (W (c, s, _, w)) =
+  let eq_prism = Eq.create () in
+  W
+    ( (None, c)
+    , s
+    , Eq.create ()
+    , fun ((x, s, (cache, c)) as input) ->
+        match cache with
+        | Some (x', s', img) when x == x' && s == s' -> input, img
+        | _ ->
+          (match Optic.Prism.extract prism x with
+          | None ->
+            let img = Dag.empty () in
+            let cache = Some (x, s, img) in
+            (x, s, (cache, c)), img
+          | Some y ->
+            let (y, s, c), img = w (y, s, c) in
+            let x = Optic.Prism.make prism y in
+            let img = Dag.into eq_prism prism img in
+            let cache = Some (x, s, img) in
+            (x, s, (cache, c)), img) )
+
+let cond predicate w = into (Prism.satisfy predicate) w
+
+let ifte predicate if_true if_false =
+  cond predicate if_true & cond (fun x -> not (predicate x)) if_false
+
+let reorder : type a b c. (a * (b * c), (b * a) * c) Optic.iso =
+  { Optic.Iso.ltor = (fun (x, (s0, s1)) -> (s0, x), s1)
+  ; rtol = (fun ((s0, x), s1) -> x, (s0, s1))
+  }
+
+let stateful s0 (W (c, s1, _, w)) =
+  let eq_iso = Eq.create () in
+  W
+    ( (None, c)
+    , (s0, s1)
+    , Eq.create ()
+    , fun ((x, (s0, s1), (cache, c)) as input) ->
+        match cache with
+        | Some (x', s0', s1', img) when x == x' && s0 == s0' && s1 == s1' -> input, img
+        | _ ->
+          let ((s0, x), s1, c), img = w ((s0, x), s1, c) in
+          let img = Dag.iso eq_iso reorder img in
+          let cache = Some (x, s0, s1, img) in
+          (x, (s0, s1), (cache, c)), img )
+
+let dynamic : type a. (a t * a) t =
+  W
+    ( ()
+    , ()
+    , Eq.unit
+    , fun (wx, (), ()) ->
+        let W (c, s, seq, w), x = wx in
+        let (x, s, c), img = w (x, s, c) in
+        let wx = W (c, s, seq, w), x in
+        let img = Dag.dynamic seq img in
+        (wx, (), ()), img )
+
+(********************************************************************************)
+
+let ( <*> ) a b = on Lens.fst a & on Lens.snd b
+
+let initialize : type a b. (a -> b) -> (b option * a, b * a) Optic.iso =
+ fun fn ->
+  { Optic.Iso.ltor =
+      (fun (s0, x) ->
+        let s0 =
+          match s0 with
+          | None -> fn x
+          | Some s0 -> s0
+        in
+        s0, x)
+  ; rtol = (fun (s0, x) -> Some s0, x)
+  }
+
+let stateful_by fn w = stateful None (iso (initialize fn) w)
+let of_lazy w = stateful_by (fun _ -> Lazy.force w) dynamic
+let apply f x = of_lazy (lazy (f x))
+
+let fix fn =
+  let rec self = lazy (fn (of_lazy self)) in
+  Lazy.force self
+
+let of_list ws = List.fold_left ( & ) empty ws
+let list w = fix (fun lst -> into Prism.cons (w <*> lst))

jsoo/attr.ml

@@ -0,0 +1,49 @@
+open! Js_of_ocaml
+module M = Map.Make (String)
+
+type value =
+  | String of string
+  | Bool of bool
+
+type t = value M.t
+
+let empty = M.empty
+let single key value = M.singleton key value
+let add key value t = M.add key value t
+
+let merge a b =
+  M.merge
+    (fun _ ox oy ->
+      match ox, oy with
+      | _, Some _ -> oy
+      | _, None -> ox)
+    a
+    b
+
+let dom_remove ~(node : Dom_html.element Js.t) key =
+  let key = Js.string key in
+  node##removeAttribute key ;
+  Js.Unsafe.delete node key
+
+let dom_add ~(node : Dom_html.element Js.t) key value =
+  let key = Js.string key in
+  match value with
+  | String value ->
+    let value = Js.string value in
+    Js.Unsafe.set node key value ;
+    node##setAttribute key value
+  | Bool value ->
+    Js.Unsafe.set node key (Js.bool value) ;
+    if value then node##setAttribute key (Js.string "") else node##removeAttribute key
+
+let update ~(node : Dom_html.element Js.t) ~old ~latest =
+  ignore
+  @@ M.merge
+       (fun key ox oy ->
+         (match ox, oy with
+         | Some _, None -> dom_remove ~node key
+         | _, Some attr -> dom_add ~node key attr
+         | _ -> ()) ;
+         None)
+       old
+       latest