Add a Thunk widget implementation (#22)

* Add a Thunk widget implementation

* Add type signatures

Author: natefaubion

src/Halogen/VDom/Thunk.purs

@@ -0,0 +1,113 @@
+module Halogen.VDom.Thunk
+  ( Thunk
+  , buildThunk
+  , runThunk
+  , hoist
+  , thunked
+  , thunk1
+  , thunk2
+  , thunk3
+  ) where
+
+import Prelude
+
+import Data.Function.Uncurried as Fn
+import Effect.Uncurried as EFn
+import Halogen.VDom as V
+import Halogen.VDom.Machine as M
+import Halogen.VDom.Util as Util
+import Unsafe.Coerce (unsafeCoerce)
+import Web.DOM.Node (Node)
+
+foreign import data ThunkArg ∷ Type
+
+foreign import data ThunkId ∷ Type
+
+data Thunk f i = Thunk ThunkId (Fn.Fn2 ThunkArg ThunkArg Boolean) (ThunkArg → f i) ThunkArg
+
+unsafeThunkId ∷ ∀ a. a → ThunkId
+unsafeThunkId = unsafeCoerce
+
+instance functorThunk ∷ Functor f ⇒ Functor (Thunk f) where
+  map f (Thunk a b c d) = Thunk a b (c >>> map f) d
+
+hoist ∷ ∀ f g. (f ~> g) → Thunk f ~> Thunk g
+hoist k (Thunk a b c d) = Thunk a b (c >>> k) d
+
+thunk ∷ ∀ a f i. Fn.Fn4 ThunkId (Fn.Fn2 a a Boolean) (a → f i) a (Thunk f i)
+thunk = Fn.mkFn4 \tid eqFn f a →
+  Thunk tid
+    (unsafeCoerce eqFn ∷ Fn.Fn2 ThunkArg ThunkArg Boolean)
+    (unsafeCoerce f ∷ ThunkArg → f i)
+    (unsafeCoerce a ∷ ThunkArg)
+
+thunked ∷ ∀ a f i. (a → a → Boolean) → (a → f i) → a → Thunk f i
+thunked eqFn f =
+  let
+    tid = unsafeThunkId { f }
+    eqFn' = Fn.mkFn2 eqFn
+  in
+    \a → Fn.runFn4 thunk tid eqFn' f a
+
+thunk1 ∷ ∀ a f i. Fn.Fn2 (a → f i) a (Thunk f i)
+thunk1 = Fn.mkFn2 \f a → Fn.runFn4 thunk (unsafeThunkId f) Util.refEq f a
+
+thunk2 ∷ ∀ a b f i. Fn.Fn3 (a → b → f i) a b (Thunk f i)
+thunk2 =
+  let
+    eqFn = Fn.mkFn2 \a b →
+      Fn.runFn2 Util.refEq a._1 b._1 &&
+      Fn.runFn2 Util.refEq a._2 b._2
+  in
+    Fn.mkFn3 \f a b →
+      Fn.runFn4 thunk (unsafeThunkId f) eqFn (\{ _1, _2 } → f _1 _2) { _1: a, _2: b }
+
+thunk3 ∷ ∀ a b c f i. Fn.Fn4 (a → b → c → f i) a b c (Thunk f i)
+thunk3 =
+  let
+    eqFn = Fn.mkFn2 \a b →
+      Fn.runFn2 Util.refEq a._1 b._1 &&
+      Fn.runFn2 Util.refEq a._2 b._2 &&
+      Fn.runFn2 Util.refEq a._3 b._3
+  in
+    Fn.mkFn4 \f a b c →
+      Fn.runFn4 thunk (unsafeThunkId f) eqFn (\{ _1, _2, _3 } → f _1 _2 _3) { _1: a, _2: b, _3: c }
+
+runThunk ∷ ∀ f i. Thunk f i → f i
+runThunk (Thunk _ _ render arg) = render arg
+
+unsafeEqThunk ∷ ∀ f i. Fn.Fn2 (Thunk f i) (Thunk f i) Boolean
+unsafeEqThunk = Fn.mkFn2 \(Thunk a1 b1 _ d1) (Thunk a2 b2 _ d2) →
+  Fn.runFn2 Util.refEq a1 a2 &&
+  Fn.runFn2 Util.refEq b1 b2 &&
+  Fn.runFn2 Util.refEq d1 d2
+
+type ThunkState f i a w =
+  { thunk ∷ Thunk f i
+  , vdom ∷ M.Step (V.VDom a w) Node
+  }
+
+buildThunk
+  ∷ ∀ f i a w
+  . (f i → V.VDom a w)
+  → V.VDomSpec a w
+  → V.Machine (Thunk f i) Node
+buildThunk toVDom = renderThunk
+  where
+  renderThunk ∷ V.VDomSpec a w → V.Machine (Thunk f i) Node
+  renderThunk spec = EFn.mkEffectFn1 \t → do
+    vdom ← EFn.runEffectFn1 (V.buildVDom spec) (toVDom (runThunk t))
+    pure $ M.mkStep $ M.Step (M.extract vdom) { thunk: t, vdom } patchThunk haltThunk
+
+  patchThunk ∷ EFn.EffectFn2 (ThunkState f i a w) (Thunk f i) (V.Step (Thunk f i) Node)
+  patchThunk = EFn.mkEffectFn2 \state t2 → do
+    let { vdom: prev, thunk: t1 } = state
+    if Fn.runFn2 unsafeEqThunk t1 t2
+      then pure $ M.mkStep $ M.Step (M.extract prev) state patchThunk haltThunk
+      else do
+        vdom ← EFn.runEffectFn2 M.step prev (toVDom (runThunk t2))
+        pure $ M.mkStep $ M.Step (M.extract vdom) { vdom, thunk: t2 } patchThunk haltThunk
+
+  haltThunk ∷ EFn.EffectFn1 (ThunkState f i a w) Unit
+  haltThunk = EFn.mkEffectFn1 \state → do
+    EFn.runEffectFn1 M.halt state.vdom

test/Main.purs

@@ -2,19 +2,19 @@ module Test.Main where
 
 import Prelude
 
-import Data.Exists (Exists, mkExists)
+import Data.Bifunctor (bimap)
 import Data.Foldable (for_, traverse_)
 import Data.Function.Uncurried as Fn
 import Data.Maybe (Maybe(..), isNothing)
-import Data.Newtype (wrap)
+import Data.Newtype (class Newtype, un, wrap)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Ref as Ref
 import Effect.Timer as Timer
 import Effect.Uncurried as EFn
 import Halogen.VDom as V
 import Halogen.VDom.DOM.Prop (Prop(..), propFromString, buildProp)
-import Halogen.VDom.Util (refEq)
+import Halogen.VDom.Thunk (Thunk, thunk1, buildThunk)
 import Unsafe.Coerce (unsafeCoerce)
 import Web.DOM.Document (Document) as DOM
 import Web.DOM.Element (toNode) as DOM
@@ -29,9 +29,12 @@ infixr 1 prop as :=
 prop ∷ ∀ a. String → String → Prop a
 prop key val = Property key (propFromString val)
 
-type VDom = V.VDom (Array (Prop Void)) (Exists Thunk)
+newtype VDom a = VDom (V.VDom (Array (Prop a)) (Thunk VDom a))
 
-data Thunk b = Thunk b (b → VDom)
+instance functorHtml ∷ Functor VDom where
+  map f (VDom vdom) = VDom (bimap (map (map f)) (map f) vdom)
+
+derive instance newtypeVDom ∷ Newtype (VDom a) _
 
 type State = Array Database
 
@@ -55,19 +58,19 @@ type DBQuery =
 initialState ∷ State
 initialState = []
 
-elem ∷ ∀ a w. String → a → Array (V.VDom a w) → V.VDom a w
-elem n a = V.Elem Nothing (V.ElemName n) a
+elem ∷ ∀ a. String → Array (Prop a) → Array (VDom a) → VDom a
+elem n a c = VDom $ V.Elem Nothing (V.ElemName n) a (unsafeCoerce c)
 
-keyed ∷ ∀ a w. String → a → Array (Tuple String (V.VDom a w)) → V.VDom a w
-keyed n a = V.Keyed Nothing (V.ElemName n) a
+keyed ∷ ∀ a. String → Array (Prop a) → Array (Tuple String (VDom a)) → VDom a
+keyed n a c = VDom $ V.Keyed Nothing (V.ElemName n) a (unsafeCoerce c)
 
-text ∷ ∀ a w. String → V.VDom a w
-text = V.Text
+text ∷ ∀ a. String → VDom a
+text a = VDom $ V.Text a
 
-thunk ∷ ∀ a. (a → VDom) → a → VDom
-thunk render val = V.Widget (mkExists (Thunk val render))
+thunk ∷ ∀ a b. (a → VDom b) → a → VDom b
+thunk render val = VDom $ V.Widget $ Fn.runFn2 thunk1 render val
 
-renderData ∷ State → VDom
+renderData ∷ State → VDom Void
 renderData st =
   elem "div" []
     [ elem "table"
@@ -108,41 +111,11 @@ renderData st =
           ]
       ]
 
-type WidgetState a w =
-  { t :: Exists Thunk
-  , step :: V.Step a w
-  }
-
-buildWidget
-  ∷ V.VDomSpec (Array (Prop Void)) (Exists Thunk)
-  → V.Machine (Exists Thunk) DOM.Node
-buildWidget spec = render
-  where
-  render = EFn.mkEffectFn1 \t → case unsafeCoerce t of
-    Thunk a render' → do
-      step ← EFn.runEffectFn1 (V.buildVDom spec) (render' a)
-      let state = { t, step }
-      pure (V.mkStep (V.Step (V.extract step) state patch done))
-
-  patch = EFn.mkEffectFn2 \state t →
-    case unsafeCoerce state.t, unsafeCoerce t of
-      Thunk a render1, Thunk b render2 →
-        if Fn.runFn2 refEq a b && Fn.runFn2 refEq render1 render2
-          then
-            pure (V.mkStep (V.Step (V.extract state.step) state patch done))
-          else do
-            step ← EFn.runEffectFn2 V.step state.step (render2 b)
-            let nextState = { t, step }
-            pure (V.mkStep (V.Step (V.extract step) nextState patch done))
-
-  done = EFn.mkEffectFn1 \state → do
-    EFn.runEffectFn1 V.halt state.step
-
 mkSpec
   ∷ DOM.Document
-  → V.VDomSpec (Array (Prop Void)) (Exists Thunk)
+  → V.VDomSpec (Array (Prop Void)) (Thunk VDom Void)
 mkSpec document = V.VDomSpec
-  { buildWidget
+  { buildWidget: buildThunk (un VDom)
   , buildAttributes: buildProp (const (pure unit))
   , document
   }
@@ -157,13 +130,13 @@ foreign import requestAnimationFrame ∷ Effect Unit → Effect Unit
 
 mkRenderQueue
   ∷ ∀ a
-  . V.VDomSpec (Array (Prop Void)) (Exists Thunk)
+  . V.VDomSpec (Array (Prop Void)) (Thunk VDom Void)
   → DOM.Node
-  → (a → VDom)
+  → (a → VDom Void)
   → a
   → Effect (a → Effect Unit)
 mkRenderQueue spec parent render initialValue = do
-  initMachine ← EFn.runEffectFn1 (V.buildVDom spec) (render initialValue)
+  initMachine ← EFn.runEffectFn1 (V.buildVDom spec) (un VDom (render initialValue))
   _ ← DOM.appendChild (V.extract initMachine) parent
   ref ← Ref.new initMachine
   val ← Ref.new Nothing
@@ -173,24 +146,24 @@ mkRenderQueue spec parent render initialValue = do
     when (isNothing v) $ requestAnimationFrame do
       machine ← Ref.read ref
       Ref.read val >>= traverse_ \v' → do
-        res ← EFn.runEffectFn2 V.step machine (render v')
+        res ← EFn.runEffectFn2 V.step machine (un VDom (render v'))
         Ref.write res ref
         Ref.write Nothing val
 
 mkRenderQueue'
   ∷ ∀ a
-  . V.VDomSpec (Array (Prop Void)) (Exists Thunk)
+  . V.VDomSpec (Array (Prop Void)) (Thunk VDom Void)
   → DOM.Node
-  → (a → VDom)
+  → (a → VDom Void)
   → a
   → Effect (a → Effect Unit)
 mkRenderQueue' spec parent render initialValue = do
-  initMachine ← EFn.runEffectFn1 (V.buildVDom spec) (render initialValue)
+  initMachine ← EFn.runEffectFn1 (V.buildVDom spec) (un VDom (render initialValue))
   _ ← DOM.appendChild (V.extract initMachine) parent
   ref ← Ref.new initMachine
   pure \v → do
     machine ← Ref.read ref
-    res ← EFn.runEffectFn2 V.step machine (render v)
+    res ← EFn.runEffectFn2 V.step machine (un VDom (render v))
     Ref.write res ref
 
 main ∷ Effect Unit