Improve memory usage with existential state (#21)

* Improve memory usage with existential state

* Fix test

* Remove ElemSpec

* Tweak test diff, names

Author: natefaubion

src/Halogen/VDom.purs

@@ -5,5 +5,5 @@ module Halogen.VDom
   ) where
 
 import Halogen.VDom.DOM (VDomSpec(..), buildVDom) as DOM
-import Halogen.VDom.Machine (Machine, Step(..), extract, step, halt) as Machine
-import Halogen.VDom.Types (VDom(..), Graft, runGraft, ElemSpec(..), ElemName(..), Namespace(..)) as Types
+import Halogen.VDom.Machine (Machine, Step, Step'(..), mkStep, unStep, extract, step, halt) as Machine
+import Halogen.VDom.Types (VDom(..), Graft, runGraft, ElemName(..), Namespace(..)) as Types

src/Halogen/VDom/DOM.purs

@@ -21,6 +21,7 @@ import Effect.Uncurried as EFn
 import Foreign (typeOf)
 import Foreign.Object as Object
 import Halogen.VDom as V
+import Halogen.VDom.Machine (Step'(..), mkStep)
 import Halogen.VDom.Types (Namespace(..))
 import Halogen.VDom.Util as Util
 import Unsafe.Coerce (unsafeCoerce)
@@ -71,35 +72,38 @@ buildProp
   . (a → Effect Unit)
   → DOM.Element
   → V.Machine (Array (Prop a)) Unit
-buildProp emit el = render
+buildProp emit el = renderProp
   where
-  render = EFn.mkEffectFn1 \ps1 → do
+  renderProp = EFn.mkEffectFn1 \ps1 → do
     events ← Util.newMutMap
     ps1' ← EFn.runEffectFn3 Util.strMapWithIxE ps1 propToStrKey (applyProp events)
-    pure
-      (V.Step unit
-        (Fn.runFn2 patch (Util.unsafeFreeze events) ps1')
-        (done ps1'))
-
-  patch = Fn.mkFn2 \prevEvents ps1 →
-    EFn.mkEffectFn1 \ps2 → do
-      events ← Util.newMutMap
-      let
-        onThese = Fn.runFn2 diffProp prevEvents events
-        onThis = removeProp prevEvents
-        onThat = applyProp events
-      ps2' ← EFn.runEffectFn6 Util.diffWithKeyAndIxE ps1 ps2 propToStrKey onThese onThis onThat
-      pure
-        (V.Step unit
-          (Fn.runFn2 patch (Util.unsafeFreeze events) ps2')
-          (done ps2'))
-
-  done ps =
-    case Object.lookup "ref" ps of
+    let
+      state =
+        { events: Util.unsafeFreeze events
+        , props: ps1'
+        }
+    pure $ mkStep $ Step unit state patchProp haltProp
+
+  patchProp = EFn.mkEffectFn2 \state ps2 → do
+    events ← Util.newMutMap
+    let
+      { events: prevEvents, props: ps1 } = state
+      onThese = Fn.runFn2 diffProp prevEvents events
+      onThis = removeProp prevEvents
+      onThat = applyProp events
+    props ← EFn.runEffectFn6 Util.diffWithKeyAndIxE ps1 ps2 propToStrKey onThese onThis onThat
+    let
+      nextState =
+        { events: Util.unsafeFreeze events
+        , props
+        }
+    pure $ mkStep $ Step unit nextState patchProp haltProp
+
+  haltProp = EFn.mkEffectFn1 \state → do
+    case Object.lookup "ref" state.props of
       Just (Ref f) →
         EFn.runEffectFn1 mbEmit (f (Removed el))
-      _ →
-        Util.effectUnit
+      _ → pure unit
 
   mbEmit = EFn.mkEffectFn1 case _ of
     Just a → emit a

src/Halogen/VDom/DOM/Prop.purs

@@ -1,28 +1,45 @@
 module Halogen.VDom.Machine
   ( Machine
-  , Step(..)
+  , Step'(..)
+  , Step
+  , mkStep
+  , unStep
   , extract
   , step
   , halt
   ) where
 
 import Prelude
 
-import Effect (Effect)
-import Effect.Uncurried (EffectFn1)
+import Effect.Uncurried (EffectFn1, EffectFn2, mkEffectFn1, mkEffectFn2, runEffectFn1, runEffectFn2)
+import Unsafe.Coerce (unsafeCoerce)
 
 type Machine a b = EffectFn1 a (Step a b)
 
-data Step a b = Step b (Machine a b) (Effect Unit)
+data Step' a b s = Step b s (EffectFn2 s a (Step a b)) (EffectFn1 s Unit)
+
+foreign import data Step ∷ Type → Type → Type
+
+mkStep ∷ ∀ a b s. Step' a b s → Step a b
+mkStep = unsafeCoerce
+
+unStep :: ∀ a b r. (∀ s. Step' a b s → r) → Step a b → r
+unStep = unsafeCoerce
 
 -- | Returns the output value of a `Step`.
 extract ∷ ∀ a b. Step a b → b
-extract (Step x _ _) = x
+extract = unStep \(Step x _ _ _) → x
 
 -- | Runs the next step.
-step ∷ ∀ a b. Step a b → EffectFn1 a (Step a b)
-step (Step _ m _) = m
+step ∷ ∀ a b. EffectFn2 (Step a b) a (Step a b)
+step = coerce $ mkEffectFn2 \(Step _ s k _) a → runEffectFn2 k s a
+  where
+  coerce ∷ ∀ s. EffectFn2 (Step' a b s) a (Step a b) → EffectFn2 (Step a b) a (Step a b)
+  coerce = unsafeCoerce
 
 -- | Runs the finalizer associated with a `Step`
-halt ∷ ∀ a b. Step a b → Effect Unit
-halt (Step _ _ h) = h
+halt ∷ ∀ a b. EffectFn1 (Step a b) Unit
+halt = coerce $ mkEffectFn1 \(Step _ s _ k) → runEffectFn1 k s
+  where
+  coerce ∷ ∀ s. EffectFn1 (Step' a b s) Unit → EffectFn1 (Step a b) Unit
+  coerce = unsafeCoerce

src/Halogen/VDom/Machine.purs

@@ -5,7 +5,6 @@ module Halogen.VDom.Types
   , graft
   , unGraft
   , runGraft
-  , ElemSpec(..)
   , ElemName(..)
   , Namespace(..)
   ) where
@@ -25,8 +24,8 @@ import Unsafe.Coerce (unsafeCoerce)
 -- | fusion using a Coyoneda-like encoding.
 data VDom a w
   = Text String
-  | Elem (ElemSpec a) (Array (VDom a w))
-  | Keyed (ElemSpec a) (Array (Tuple String (VDom a w)))
+  | Elem (Maybe Namespace) ElemName a (Array (VDom a w))
+  | Keyed (Maybe Namespace) ElemName a (Array (Tuple String (VDom a w)))
   | Widget w
   | Grafted (Graft a w)
 
@@ -72,19 +71,13 @@ runGraft =
   unGraft \(Graft fa fw v) →
     let
       go (Text s) = Text s
-      go (Elem spec ch) = Elem (map fa spec) (map go ch)
-      go (Keyed spec ch) = Keyed (map fa spec) (map (map go) ch)
+      go (Elem ns n a ch) = Elem ns n (fa a) (map go ch)
+      go (Keyed ns n a ch) = Keyed ns n (fa a) (map (map go) ch)
       go (Widget w) = Widget (fw w)
       go (Grafted g) = Grafted (bimap fa fw g)
     in
       go v
 
-data ElemSpec a = ElemSpec (Maybe Namespace) ElemName a
-
-derive instance eqElemSpec ∷ Eq a ⇒ Eq (ElemSpec a)
-derive instance ordElemSpec ∷ Ord a ⇒ Ord (ElemSpec a)
-derive instance functorElemSpec ∷ Functor ElemSpec
-
 newtype ElemName = ElemName String
 
 derive instance newtypeElemName ∷ Newtype ElemName _

src/Halogen/VDom/Types.purs

@@ -17,11 +17,17 @@ exports.unsafeDeleteAny = function (key, obj) {
 };
 
 exports.forE = function (a, f) {
-    var b = [];
-    for (var i = 0; i < a.length; i++) {
-      b.push(f(i, a[i]));
-    }
-    return b;
+  var b = [];
+  for (var i = 0; i < a.length; i++) {
+    b.push(f(i, a[i]));
+  }
+  return b;
+};
+
+exports.forEachE = function (a, f) {
+  for (var i = 0; i < a.length; i++) {
+    f(a[i]);
+  }
 };
 
 exports.forInE = function (o, f) {

src/Halogen/VDom/Util.js

@@ -1,7 +1,5 @@
 module Halogen.VDom.Util
-  ( effectPure
-  , effectUnit
-  , newMutMap
+  ( newMutMap
   , pokeMutMap
   , deleteMutMap
   , unsafeFreeze
@@ -11,6 +9,7 @@ module Halogen.VDom.Util
   , unsafeSetAny
   , unsafeDeleteAny
   , forE
+  , forEachE
   , forInE
   , replicateE
   , diffWithIxE
@@ -48,12 +47,6 @@ import Web.DOM.Element (Element) as DOM
 import Web.DOM.Node (Node) as DOM
 import Web.Event.EventTarget (EventListener) as DOM
 
-effectPure ∷ ∀ a. a → Effect a
-effectPure = pure
-
-effectUnit ∷ Effect Unit
-effectUnit = pure unit
-
 newMutMap ∷ ∀ r a. Effect (STObject r a)
 newMutMap = unsafeCoerce STObject.new
 
@@ -87,6 +80,13 @@ foreign import forE
       (EFn.EffectFn2 Int a b)
       (Array b)
 
+foreign import forEachE
+  ∷ ∀ a
+  . EFn.EffectFn2
+      (Array a)
+      (EFn.EffectFn1 a Unit)
+      Unit
+
 foreign import forInE
   ∷ ∀ a
   . EFn.EffectFn2

src/Halogen/VDom/Util.purs

@@ -56,10 +56,10 @@ initialState ∷ State
 initialState = []
 
 elem ∷ ∀ a w. String → a → Array (V.VDom a w) → V.VDom a w
-elem n a = V.Elem (V.ElemSpec Nothing (V.ElemName n) a)
+elem n a = V.Elem Nothing (V.ElemName n) a
 
 keyed ∷ ∀ a w. String → a → Array (Tuple String (V.VDom a w)) → V.VDom a w
-keyed n a = V.Keyed (V.ElemSpec Nothing (V.ElemName n) a)
+keyed n a = V.Keyed Nothing (V.ElemName n) a
 
 text ∷ ∀ a w. String → V.VDom a w
 text = V.Text
@@ -108,24 +108,35 @@ 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
-      V.Step node m h ← EFn.runEffectFn1 (V.buildVDom spec) (render' a)
-      pure (V.Step node (Fn.runFn4 patch (unsafeCoerce a) node m h) h)
-
-  patch = Fn.mkFn4 \a node step halt →
-    EFn.mkEffectFn1 \t → case unsafeCoerce t of
-      Thunk b render' →
-        if Fn.runFn2 refEq a b
-          then pure (V.Step node (Fn.runFn4 patch a node step halt) halt)
+      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
-            V.Step node' m h ← EFn.runEffectFn1 step (render' b)
-            pure (V.Step node' (Fn.runFn4 patch (unsafeCoerce b) node' m h) h)
+            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
@@ -162,7 +173,7 @@ mkRenderQueue spec parent render initialValue = do
     when (isNothing v) $ requestAnimationFrame do
       machine ← Ref.read ref
       Ref.read val >>= traverse_ \v' → do
-        res ← EFn.runEffectFn1 (V.step machine) (render v')
+        res ← EFn.runEffectFn2 V.step machine (render v')
         Ref.write res ref
         Ref.write Nothing val
 
@@ -179,7 +190,7 @@ mkRenderQueue' spec parent render initialValue = do
   ref ← Ref.new initMachine
   pure \v → do
     machine ← Ref.read ref
-    res ← EFn.runEffectFn1 (V.step machine) (render v)
+    res ← EFn.runEffectFn2 V.step machine (render v)
     Ref.write res ref
 
 main ∷ Effect Unit