Shpadoinkle 0.3.0.0 → 0.3.1.0

raw patch · 6 files changed

+335/−442 lines, 6 filesdep +deepseqdep +mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq, mtl

API changes (from Hackage documentation)

Files

• CHANGELOG.md +0/−0
• README.md +2/−184
• Shpadoinkle.cabal +40/−31
• Shpadoinkle/Continuation.hs +211/−93
• Shpadoinkle/Core.hs +81/−133
• Shpadoinkle/Run.hs +1/−1

@@ -1,6 +1,6 @@ # Shpadoinkle Core -[![Goldwater](https://gitlab.com/fresheyeball/Shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/fresheyeball/Shpadoinkle)+[![Goldwater](https://gitlab.com/platonic/shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/platonic/shpadoinkle) [![Haddock](https://img.shields.io/badge/haddock-master-informational)](https://shpadoinkle.org/core) [![BSD-3](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause) [![built with nix](https://img.shields.io/badge/built%20with-nix-41439a)](https://builtwithnix.org)@@ -8,186 +8,4 @@ [![Hackage Deps](https://img.shields.io/hackage-deps/v/Shpadoinkle.svg)](http://packdeps.haskellers.com/reverse/Shpadoinkle) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/Shpadoinkle/badge)](https://matrix.hackage.haskell.org/#/package/Shpadoinkle) -Shpadoinkle is a Haskell UI programming paradigm.--## The core concept--Is to model the user interface as a pure function from some model `a` to Html.-This is not a new idea in the slightest. Declaratively describing the view in terms-of the model through a data structure is the dominant approach in UI today. And-for good reason.--If all we need is to render something based on some `a` we can have `Html` be a-simple data structure where `Html :: Type`:--```haskell-view :: a -> Html-```--This might look something like:--```haskell-view :: Text -> Html-view username =-  H "div" [ ("class", "greeting") ] [ Text $ "Hi there!" <> username ]-```--## Events and effects--Which is all well and good, and something we might expect from a static renderer,-like Heist, or Blaze. Shpadoinkle handles this by allowing for `Html` to have two-type variables associated with events, `Html :: (Type -> Type) -> Type -> Type`.--The first is typically some Monad you want to use in response to events `m`, and-the second is the payload of those events, typically the model for your view `a`.--These variables in `Html m a` are strickly about event listeners, so any view-that doesn't have event listeners should be parametic in both `m` and `a`.--look at a toggle as an example:--```haskell-toggle :: Applicative m => Bool -> Html m Bool-toggle b = h "div" []-  [ text $ "Currently it's " <> if b then "ON" else "OFF"-  , h "button" [ listen "click" (not b) ] [ text "Toggle" ]-  ]-```--That's it, we have a stateful view. When the user click's on-the "Toggle" button the state will switch. Because we do a pure-state transition in this function, `m` need only be `Applicative`.-We could put `Identity` here if we wanted to, but keeping `m` general-helps our views compose.--But what if we need to do _more_? Well we can update our `m` to-have more functionality. We can add some logging to the console:--```haskell-toggle :: Bool -> Html IO Bool-toggle b = h "div" []-  [ text $ "Currently it's " <> if b then "ON" else "OFF"-  , h "button"-    [ listen' "click" $ do-        putStrLn "We toggled!"-        return $ not b-    ] [ text "Toggle" ]-  ]-```--What if we want to access some record of capabilities? Or update some-concurrent memory thing? Let's say we have an enterprise grade Monad:--```haskell-newtype App a = App { runApp :: RIO (TVar Metrics) a }-  deriving (Functor, Applicative, Monad, MonadReader (TVar Metrics), MonadIO, MonadJSM)---toggle :: Bool -> Html App Bool-toggle b = h "div" []-  [ text $ "Currently it's " <> if b then "ON" else "OFF"-  , h "button"-    [ listen' "click" $ do-        metrics <- ask-        liftIO $ do-          atomically . modifyTVar metrics $-            \m -> m { toggleCount = toggleCount m + 1 }-          putStrLn "We toggled!"-        return $ not b-    ] [ text "Toggle" ]-  ]-```--## Composing views--In Shpadoinkle we can compose views without impedance if the types match,-or are parametric. For example:--```haskell-hero :: Html m a-hero = h "h1" [] [ text "Online String Reverse" ]--input :: Html m Text-input = h "input" [ onInput id ] []--view :: Text -> Html m Text-view s = h "div" []-  [ hero  -- no impedance, this Html is fully generic-  , input -- no impedance, this Html has matching types `(Text ~ Text)`-  , text $ "Reversed: \"" <> reverse s <> "\""-  ]-```--If you have nesting, with different types,-we can resolve the mismatch using 'fmap' like so:--```haskell-input :: Html m Text-input = h "input" [ onInput id ] []--view :: (Int, Text) -> Html m (Int, Text)-view (i,t) = h "div" []--  -- here we update the `Text` side of the model-  -- with the value produced by `input`, and we-  -- increment the `Int` as well.-  [ (\t_ -> (i + 1, t_)) <$> input-  , text $ "Reversed: \"" <> reverse t <> "\""-  , text $ "you have reversed " <> pack (show i) <> " strings"-  ]-```--## The primitive--The Shpadoinkle programming model core primitive is the `shpadoinkle` function.--```haskell-shpadoinkle-  :: (Shpadoinkle b m a, Territory t, Eq a) =>-  => (m ~> JSM) -> (t a -> b m ~> m) -- How to render-  -> a -> t a                        -- What is our model-  -> (a -> Html (b m) a)             -- What to render-  -> b m RawNode -> JSM ()           -- Actually render-```--This is the machine that runs a Shpadoinkle view. To run we need-the following ingredients:--### `m ~> JSM`--We need a _Natural Transformation_ from our `m` to `JSM`, so that-we can perform the needed JavaScript effects in JSM from the `m`-you provide.--### `t a -> b m ~> m`--This a function that takes a state container of some kind `t`,-and returns a _Natural Transformation_ from our Shpadoinkle backend `b`,-to our monad `m`. Backends kind of works like Monad Transformers, where-`b` wraps our Monad `m`, and needs to be unwrappable.--### `a`--This is the initial value of our model. This will be passed to our view-for the first render.--### `t a`--This is the state container `t` that will drive the view. When the state-changes, we should re-render the view. The semantic behind determing when-to do this, is upto you via the `Territory` type class. Typically this is-just a `TVar` as that is the provided cannonical implimentation.--### `a -> Html (b m) a`--This is the view function, you actual application to render. It takes-the model and returns the html to render, such that it's events produce the-same model.--### `b m RawNode`--This is the raw node we that will wrap our view. If you want the Shpadoinkle view-to be the entire page, then you want to pass `document.body` as this node.-You could use this to embed a Shpadoinkle application into another application,-(such a Reflex-dom or Miso).-+## [Documentation ->](https://shpadoinkle.org/packages/core)

@@ -1,54 +1,63 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.33.0.------ see: https://github.com/sol/hpack------ hash: 551573dac4a13219ffcfb0a630517ffaeef58089ef1c69e2feb128417516a320--name:           Shpadoinkle-version:        0.3.0.0-synopsis:       A programming model for declarative, high performance user interface.-description:    Shpadoinkle is an abstract frontend programming model, with one-way data flow, and a single source of truth. This module provides a parsimonious implementation of Shpadoinkle with few implementation details.-category:       Web-author:         Isaac Shapira-maintainer:     fresheyeball@protonmail.com-license:        BSD3-license-file:   LICENSE-build-type:     Simple+cabal-version: 2.2+name:          Shpadoinkle+version:       0.3.1.0+category:      Web+author:        Isaac Shapira+maintainer:    isaac.shapira@platonic.systems+license:       BSD-3-Clause+license-file:  LICENSE+build-type:    Simple extra-source-files:-    README.md-    CHANGELOG.md+  README.md+synopsis:+  A programming model for declarative, high performance user interface.+description:+  Shpadoinkle is an abstract frontend programming model, with one-way data flow,+  and a single source of truth. This module provides a parsimonious implementation+  of Shpadoinkle with few implementation details. + source-repository head   type: git-  location: https://gitlab.com/fresheyeball/Shpadoinkle.git+  location: https://gitlab.com/platonic/shpadoinkle.git + library   exposed-modules:-      Control.PseudoInverseCategory-      Shpadoinkle-      Shpadoinkle.Continuation-      Shpadoinkle.Core-      Shpadoinkle.Run-  other-modules:-      Paths_Shpadoinkle-  hs-source-dirs:-      ./.-  ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities+    Control.PseudoInverseCategory+    Shpadoinkle+    Shpadoinkle.Continuation+    Shpadoinkle.Core+    Shpadoinkle.Run++  hs-source-dirs: .++  ghc-options:+    -Wall+    -Wcompat+    -fwarn-redundant-constraints+    -fwarn-incomplete-uni-patterns+    -fwarn-tabs+    -fwarn-incomplete-record-updates+    -fwarn-identities+   build-depends:       base >=4.12.0 && <4.16     , category >=0.2 && <0.3     , containers+    , deepseq     , ghcjs-dom >=0.9.4 && <0.20     , jsaddle >=0.9.7 && <0.20+    , mtl     , text >=1.2.3 && <1.3     , transformers     , unliftio+   if !impl(ghcjs)     build-depends:         jsaddle-warp >=0.9.7 && <0.20       , wai       , wai-app-static       , warp+   default-language: Haskell2010

@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-} {-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes            #-}@@ -11,13 +13,14 @@   It allows for asynchronous effects in event handlers by providing a model for atomic updates   of application state. -}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}   module Shpadoinkle.Continuation (   -- * The Continuation Type   Continuation (..)   , runContinuation-  , done, pur, impur, kleisli, causes, contIso+  , done, pur, impur, kleisli, causes, causedBy, merge, contIso, before, after   -- * The Class   , Continuous (..)   -- ** Hoist@@ -37,20 +40,31 @@   , writeUpdate, shouldUpdate, constUpdate   -- * Monad Transformer   , ContinuationT (..), voidRunContinuationT, kleisliT, commit+  -- * Re-exports+  , module Control.DeepSeq   ) where  -import           Control.Arrow                 (first)-import qualified Control.Categorical.Functor   as F-import           Control.Monad                 (liftM2, void)-import           Control.Monad.Trans.Class     (MonadTrans (..))-import           Control.PseudoInverseCategory (EndoIso (..))-import           Data.Maybe                    (fromMaybe)-import           GHC.Conc                      (retry)-import           UnliftIO                      (MonadUnliftIO, TVar, atomically,-                                                newTVarIO, readTVar, readTVarIO,-                                                writeTVar)-import           UnliftIO.Concurrent           (forkIO)+import           Control.Arrow                       (first)+import qualified Control.Categorical.Functor         as F+import           Control.DeepSeq                     (NFData (..), force)+import           Control.Monad                       (void)+import           Control.Monad.Trans.Class           (MonadTrans (..))+import           Control.PseudoInverseCategory       (EndoIso (..))+import           Data.Foldable                       (traverse_)+import           Data.Maybe                          (fromMaybe)+import           GHC.Conc                            (retry)+import           GHCJS.DOM                           (currentWindowUnchecked)+import           GHCJS.DOM.Window                    (Window)+import           GHCJS.DOM.WindowOrWorkerGlobalScope (clearTimeout, setTimeout)+import           Language.Javascript.JSaddle         (MonadJSM, fun, JSM)+import           UnliftIO                            (MonadUnliftIO, TVar,+                                                      UnliftIO, askUnliftIO,+                                                      atomically, liftIO,+                                                      newTVarIO, readTVar,+                                                      readTVarIO, unliftIO,+                                                      writeTVar)+import           UnliftIO.Concurrent                 (forkIO)   -- | A Continuation builds up an@@ -70,8 +84,9 @@ --   (even if it changed since the start of computing the Continuation), and the updates made --   so far, although those updates are not committed to the real state until the Continuation --   finishes and they are all done atomically together.-data Continuation m a = Continuation (a -> a, a -> m (Continuation m a))+data Continuation m a = Continuation (a -> a) (a -> m (Continuation m a))                       | Rollback (Continuation m a)+                      | Merge (Continuation m a)                       | Pure (a -> a)  @@ -89,24 +104,48 @@   -- | A monadic computation of a pure state updating function can be turned into a Continuation.-impur :: Monad m => m (a -> a) -> Continuation m a-impur m = Continuation . (id,) . const $ do-  f <- m-  return $ Continuation (f, const (return done))+{-# SPECIALIZE impur :: JSM (a -> a) -> Continuation JSM a #-}+impur :: Applicative m => m (a -> a) -> Continuation m a+impur m = kleisli . const $ (\f -> Continuation f (const (pure done))) <$> m   -- | This turns a Kleisli arrow for computing a Continuation into the Continuation which --   reads the state, runs the monadic computation specified by the arrow on that state, --   and runs the resulting Continuation. kleisli :: (a -> m (Continuation m a)) -> Continuation m a-kleisli = Continuation . (id,)+kleisli = Continuation id   -- | A monadic computation can be turned into a Continuation which does not touch the state.-causes :: Monad m => m () -> Continuation m a-causes m = impur (m >> return id)+{-# SPECIALIZE causes :: JSM () -> Continuation JSM a #-}+causes :: Applicative m => m () -> Continuation m a+causes m = impur (id <$ m)  +causedBy :: m (Continuation m a) -> Continuation m a+causedBy = Continuation id . const+++-- | A continuation can be forced to write its changes midflight.+merge :: Continuation m a -> Continuation m a+merge = Merge+++-- | Sequences two continuations one after the other.+before :: Applicative m => Continuation m a -> Continuation m a -> Continuation m a+Pure f `before` Continuation g h = Continuation (g . f) h+Pure _ `before` Rollback g = g+Pure f `before` Merge g = Continuation f (const (pure (Merge g)))+Pure f `before` Pure g = Pure (g.f)+Merge f `before` g = Merge (f `before` g)+Rollback f `before` g = Rollback (f `before` g)+Continuation f g `before` h = Continuation f $ fmap (`before` h) . g+++after :: Applicative m => Continuation m a -> Continuation m a -> Continuation m a+after = flip before++ -- | 'runContinuation' takes a 'Continuation' and a state value and runs the whole Continuation --   as if the real state was frozen at the value given to 'runContinuation'. It performs all the --   IO actions in the stages of the Continuation and returns a pure state updating function@@ -115,15 +154,18 @@ --   territory, then you should probably be using 'writeUpdate' instead of 'runContinuation', --   because 'writeUpdate' will allow each stage of the Continuation to see any extant updates --   made to the territory after the Continuation started running.+{-# SPECIALIZE runContinuation :: Continuation JSM a -> a -> JSM (a -> a) #-} runContinuation :: Monad m => Continuation m a -> a -> m (a -> a) runContinuation = runContinuation' id  +{-# SPECIALIZE runContinuation' :: (a -> a) -> Continuation JSM a -> a -> JSM (a -> a) #-} runContinuation' :: Monad m => (a -> a) -> Continuation m a -> a -> m (a -> a)-runContinuation' f (Continuation (g, h)) x = do+runContinuation' f (Continuation g h) x = do   i <- h (f x)   runContinuation' (g.f) i x runContinuation' _ (Rollback f) x = runContinuation' id f x+runContinuation' f (Merge g) x = runContinuation' f g x runContinuation' f (Pure g) _ = return (g.f)  @@ -138,85 +180,105 @@   -- | Given a natural transformation, change a Continuation's underlying functor.+{-# SPECIALIZE hoist :: (forall b. JSM b -> n b) -> Continuation JSM a -> Continuation n a #-} hoist :: Functor m => (forall b. m b -> n b) -> Continuation m a -> Continuation n a hoist _ (Pure f)              = Pure f hoist f (Rollback r)          = Rollback (hoist f r)-hoist f (Continuation (g, h)) = Continuation . (g,) $ \x -> f $ hoist f <$> h x+hoist f (Merge g)             = Merge (hoist f g)+hoist f (Continuation g h) = Continuation g $ \x -> f $ hoist f <$> h x   -- | Apply a lens inside a Continuation to change the Continuation's type.+{-# SPECIALIZE liftC' :: (a -> b -> b) -> (b -> a) -> Continuation JSM a -> Continuation JSM b #-} liftC' :: Functor m => (a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b-liftC' f g (Pure h) = Pure (\x -> f (h (g x)) x)-liftC' f g (Rollback r) = Rollback (liftC' f g r)-liftC' f g (Continuation (h, i)) = Continuation (\x -> f (h (g x)) x, \x -> liftC' f g <$> i (g x))+liftC' f g (Pure h)              = Pure (\x -> f (h (g x)) x)+liftC' f g (Rollback r)          = Rollback (liftC' f g r)+liftC' f g (Merge h)             = Merge (liftC' f g h)+liftC' f g (Continuation h i) = Continuation (\x -> f (h (g x)) x) (\x -> liftC' f g <$> i (g x))   -- | Apply a traversal inside a Continuation to change the Continuation's type.+{-# SPECIALIZE liftCMay' :: (a -> b -> b) -> (b -> Maybe a) -> Continuation JSM a -> Continuation JSM b #-} liftCMay' :: Applicative m => (a -> b -> b) -> (b -> Maybe a) -> Continuation m a -> Continuation m b liftCMay' f g (Pure h)     = Pure $ \x -> maybe x (flip f x . h) $ g x liftCMay' f g (Rollback r) = Rollback (liftCMay' f g r)-liftCMay' f g (Continuation (h, i)) =-  Continuation (\x -> maybe x (flip f x . h) $ g x, maybe (pure done) (fmap (liftCMay' f g) . i) . g)+liftCMay' f g (Merge h)    = Merge (liftCMay' f g h)+liftCMay' f g (Continuation h i) =+  Continuation (\x -> maybe x (flip f x . h) $ g x) ( maybe (pure done) (fmap (liftCMay' f g) . i) . g)   -- | Given a lens, change the value type of @f@ by applying the lens in the Continuations inside @f@.+{-# SPECIALIZE liftC :: Functor m => (a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b #-} liftC :: Functor m => Continuous f => (a -> b -> b) -> (b -> a) -> f m a -> f m b liftC f g = mapC (liftC' f g)   -- | Given a traversal, change the value of @f@ by apply the traversal in the Continuations inside @f@.+{-# SPECIALIZE liftCMay :: Applicative m => (a -> b -> b) -> (b -> Maybe a) -> Continuation m a -> Continuation m b #-} liftCMay :: Applicative m => Continuous f => (a -> b -> b) -> (b -> Maybe a) -> f m a -> f m b liftCMay f g = mapC (liftCMay' f g)   -- | Change a void continuation into any other type of Continuation.+{-# SPECIALIZE voidC' :: Continuation JSM () -> Continuation JSM a #-} voidC' :: Monad m => Continuation m () -> Continuation m a-voidC' f = Continuation . (id,) $ \_ -> do+voidC' f = Continuation id $ \_ -> do   _ <- runContinuation f ()   return done   -- | Change the type of the f-embedded void Continuations into any other type of Continuation.+{-# SPECIALIZE voidC :: Monad m => Continuation m () -> Continuation m a #-}+{-# SPECIALIZE voidC :: Continuation JSM () -> Continuation JSM a #-} voidC :: Monad m => Continuous f => f m () -> f m a voidC = mapC voidC'   -- | Forget about the Continuations.+{-# SPECIALIZE forgetC :: Continuation m a -> Continuation m b #-}+{-# SPECIALIZE forgetC :: Continuation JSM a -> Continuation JSM b #-} forgetC :: Continuous f => f m a -> f m b forgetC = mapC (const done)   --- | Change the type of a Continuation by applying it to the left coordinate of a tuple.+{-# SPECIALIZE leftC' :: Continuation JSM a -> Continuation JSM (a,b) #-} leftC' :: Functor m => Continuation m a -> Continuation m (a,b) leftC' = liftC' (\x (_,y) -> (x,y)) fst   -- | Change the type of @f@ by applying the Continuations inside @f@ to the left coordinate of a tuple.+{-# SPECIALIZE leftC :: Continuation JSM a -> Continuation JSM (a,b) #-} leftC :: Functor m => Continuous f => f m a -> f m (a,b) leftC = mapC leftC'   -- | Change the type of a Continuation by applying it to the right coordinate of a tuple.+{-# SPECIALIZE rightC' :: Continuation JSM b -> Continuation JSM (a,b) #-} rightC' :: Functor m => Continuation m b -> Continuation m (a,b) rightC' = liftC' (\y (x,_) -> (x,y)) snd   -- | Change the value type of @f@ by applying the Continuations inside @f@ to the right coordinate of a tuple.+{-# SPECIALIZE rightC :: Continuation JSM b -> Continuation JSM (a,b) #-} rightC :: Functor m => Continuous f => f m b -> f m (a,b) rightC = mapC rightC'   -- | Transform a Continuation to work on 'Maybe's. If it encounters 'Nothing', then it cancels itself.+{-# SPECIALIZE maybeC' :: Continuation JSM a -> Continuation JSM (Maybe a) #-} maybeC' :: Applicative m => Continuation m a -> Continuation m (Maybe a)-maybeC' (Pure f) = Pure (fmap f)-maybeC' (Rollback r) = Rollback (maybeC' r)-maybeC' (Continuation (f, g)) = Continuation . (fmap f,) $+maybeC' (Pure f)              = Pure (fmap f)+maybeC' (Rollback r)          = Rollback (maybeC' r)+maybeC' (Merge f)             = Merge (maybeC' f)+maybeC' (Continuation f g) = Continuation (fmap f) $   \case     Just x  -> maybeC' <$> g x     Nothing -> pure (Rollback done)   -- | Change the value type of @f@ by transforming the Continuations inside @f@ to work on 'Maybe's using maybeC'.+{-# SPECIALIZE maybeC' :: Continuation JSM a -> Continuation JSM (Maybe a) #-} maybeC :: Applicative m => Continuous f => f m a -> f m (Maybe a) maybeC = mapC maybeC' @@ -231,13 +293,16 @@ --   The resulting Continuation acts like the input Continuation except that --   when the input Continuation would replace the current value with 'Nothing', --   instead the current value is retained.+{-# SPECIALIZE comaybeC' :: Continuation JSM (Maybe a) -> Continuation JSM a #-} comaybeC' :: Functor m => Continuation m (Maybe a) -> Continuation m a-comaybeC' (Pure f) = Pure (comaybe f)-comaybeC' (Rollback r) = Rollback (comaybeC' r)-comaybeC' (Continuation (f,g)) = Continuation (comaybe f, fmap comaybeC' . g . Just)+comaybeC' (Pure f)             = Pure (comaybe f)+comaybeC' (Rollback r)         = Rollback (comaybeC' r)+comaybeC' (Merge f)            = Merge (comaybeC' f)+comaybeC' (Continuation f g) = Continuation (comaybe f) ( fmap comaybeC' . g . Just)   -- | Transform the Continuations inside @f@ using comaybeC'.+{-# SPECIALIZE comaybeC :: Continuation JSM (Maybe a) -> Continuation JSM a #-} comaybeC :: Functor m => Continuous f => f m (Maybe a) -> f m a comaybeC = mapC comaybeC' @@ -260,20 +325,23 @@ --   If the state is in a different Either-branch when the Continuation --   completes than it was when the Continuation started, then the --   coproduct Continuation will have no effect on the state.-eitherC' :: Monad m => Continuation m a -> Continuation m b -> Continuation m (Either a b)-eitherC' f g = Continuation . (id,) $ \case+{-# SPECIALIZE eitherC' :: Continuation JSM a -> Continuation JSM b -> Continuation JSM (Either a b) #-}+eitherC' :: Applicative m => Continuation m a -> Continuation m b -> Continuation m (Either a b)+eitherC' f g = Continuation id $ \case   Left x -> case f of-    Pure h -> return (Pure (mapLeft h))-    Rollback r -> return . Rollback $ eitherC' r done-    Continuation (h, i) -> do-      j <- i x-      return $ Continuation (mapLeft h, const . return $ eitherC' j (Rollback done))+    Pure h -> pure (Pure (mapLeft h))+    Rollback r -> pure . Rollback $ eitherC' r done+    Merge h -> pure . Merge $ eitherC' h done+    Continuation h i ->+      (\j -> Continuation (mapLeft h) ( const . pure $ eitherC' j (Rollback done)))+        <$> i x   Right x -> case g of-    Pure h -> return (Pure (mapRight h))-    Rollback r -> return . Rollback $ eitherC' done r-    Continuation (h, i) -> do-      j <- i x-      return $ Continuation (mapRight h, const . return $ eitherC' (Rollback done) j)+    Pure h -> pure (Pure (mapRight h))+    Rollback r -> pure . Rollback $ eitherC' done r+    Merge h -> pure . Merge $ eitherC' done h+    Continuation h i ->+      (\j -> Continuation (mapRight h) (const . pure $ eitherC' (Rollback done) j))+        <$> i x   -- | Create a structure containing coproduct Continuations using two case@@ -281,88 +349,135 @@ --   the types inside the coproduct. The Continuations in the resulting --   structure will only have effect on the state while it is in the branch --   of the coproduct selected by the input value used to create the structure.-eitherC :: Monad m => Continuous f => (a -> f m a) -> (b -> f m b) -> Either a b -> f m (Either a b)+{-# SPECIALIZE eitherC :: (a -> Continuation JSM a) -> (b -> Continuation JSM b) -> Either a b -> Continuation JSM (Either a b) #-}+eitherC :: Applicative m => Continuous f => (a -> f m a) -> (b -> f m b) -> Either a b -> f m (Either a b) eitherC l _ (Left x)  = mapC (\c -> eitherC' c (pur id)) (l x) eitherC _ r (Right x) = mapC (eitherC' (pur id)) (r x)   -- | Transform the type of a Continuation using an isomorphism.+{-# SPECIALIZE contIso :: (a -> b) -> (b -> a) -> Continuation JSM a -> Continuation JSM b #-} contIso :: Functor m => (a -> b) -> (b -> a) -> Continuation m a -> Continuation m b-contIso f g (Continuation (h, i)) = Continuation (f.h.g, fmap (contIso f g) . i . g)+contIso f g (Continuation h i) = Continuation (f.h.g) (fmap (contIso f g) . i . g) contIso f g (Rollback h) = Rollback (contIso f g h)-contIso f g (Pure h) = Pure (f.h.g)+contIso f g (Merge h)    = Merge (contIso f g h)+contIso f g (Pure h)     = Pure (f.h.g)   -- | @Continuation m@ is a Functor in the EndoIso category (where the objects --   are types and the morphisms are EndoIsos). instance Applicative m => F.Functor EndoIso EndoIso (Continuation m) where+  map :: EndoIso a b -> EndoIso  (Continuation m a) (Continuation m b)   map (EndoIso f g h) =-    EndoIso (Continuation . (f,) . const . pure) (contIso g h) (contIso h g)+    EndoIso (Continuation f . const . pure) (contIso g h) (contIso h g)   -- | You can combine multiple Continuations homogeneously using the 'Monoid' typeclass --   instance. The resulting Continuation will execute all the subcontinuations in parallel, --   allowing them to see each other's state updates and roll back each other's updates,---   applying all of the updates generated by all the subcontinuations atomically once---   all of them are done.-instance Monad m => Semigroup (Continuation m a) where-  (Continuation (f, g)) <> (Continuation (h, i)) =-    Continuation (f.h, \x -> liftM2 (<>) (g x) (i x))-  (Continuation (f, g)) <> (Rollback h) =-    Rollback (Continuation (f, \x -> liftM2 (<>) (g x) (return h)))-  (Rollback h) <> (Continuation (_, g)) =-    Rollback (Continuation (id, fmap (h <>) . g))+--   applying all of the unmerged updates generated by all the subcontinuations atomically once+--   all of them are done. A merge in any one of the branches will cause all of+--   the changes that branch can see to be merged.+instance Applicative m => Semigroup (Continuation m a) where+  (Continuation f g) <> (Continuation h i) =+    Continuation (f.h) (\x -> (<>) <$> g x <*> i x)+  (Continuation f g) <> (Rollback h) =+    Rollback (Continuation f (fmap (<> h) . g))+  (Rollback h) <> (Continuation _ g) =+    Rollback (Continuation id (fmap (h <>) . g))   (Rollback f) <> (Rollback g) = Rollback (f <> g)   (Pure f) <> (Pure g) = Pure (f.g)-  (Pure f) <> (Continuation (g,h)) = Continuation (f.g,h)-  (Continuation (f,g)) <> (Pure h) = Continuation (f.h,g)-  (Pure f) <> (Rollback g) = Continuation (f, const (return (Rollback g)))+  (Pure f) <> (Continuation g h) = Continuation (f.g) h+  (Continuation f g) <> (Pure h) = Continuation (f.h) g+  (Pure f) <> (Rollback g) = Continuation f (const (pure (Rollback g)))   (Rollback f) <> (Pure _) = Rollback f+  (Merge f) <> g = Merge (f <> g)+  f <> (Merge g) = Merge (f <> g)   -- | Since combining Continuations homogeneously is an associative operation, --   and this operation has a unit element (done), Continuations are a 'Monoid'.-instance Monad m => Monoid (Continuation m a) where+instance Applicative m => Monoid (Continuation m a) where   mempty = done  -writeUpdate' :: MonadUnliftIO m => (a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()+{-# SPECIALIZE writeUpdate' :: NFData a => (a -> a) -> TVar a -> (a -> JSM (Continuation JSM a)) -> JSM () #-}+writeUpdate' :: MonadUnliftIO m => NFData a => (a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m () writeUpdate' h model f = do   i <- readTVarIO model   m <- f (h i)   case m of-    Continuation (g,gs) -> writeUpdate' (g.h) model gs+    Continuation g gs -> writeUpdate' (g . h) model gs     Pure g -> atomically (writeTVar model . g . h =<< readTVar model)+    Merge g -> do+      atomically $ writeTVar model . h =<< readTVar model+      writeUpdate' id model (const (return g))     Rollback gs -> writeUpdate' id model (const (return gs))   -- | Run a Continuation on a state variable. This may update the state. --   This is a synchronous, non-blocking operation for pure updates, --   and an asynchronous, non-blocking operation for impure updates.-writeUpdate :: MonadUnliftIO m => TVar a -> Continuation m a -> m ()+{-# SPECIALIZE writeUpdate :: NFData a => TVar a -> Continuation JSM a -> JSM () #-}+writeUpdate :: MonadUnliftIO m => NFData a => TVar a -> Continuation m a -> m () writeUpdate model = \case-  Continuation (f,g) -> void . forkIO $ writeUpdate' f model g-  Pure f             -> atomically (writeTVar model . f =<< readTVar model)-  Rollback f         -> writeUpdate model f+  Continuation f g -> void . forkIO $ writeUpdate' f model g+  Pure f           -> atomically (writeTVar model . f =<< readTVar model)+  Merge f          -> writeUpdate model f+  Rollback f       -> writeUpdate model f   -- | Execute a fold by watching a state variable and executing the next --   step of the fold each time it changes.-shouldUpdate :: MonadUnliftIO m => Eq a => (b -> a -> m b) -> b -> TVar a -> m ()-shouldUpdate sun prev model = do-  i' <- readTVarIO model-  p  <- newTVarIO i'-  () <$ forkIO (go prev p)-  where-    go x p = do-      a <- atomically $ do-        new' <- readTVar model-        old  <- readTVar p-        if new' == old then retry else new' <$ writeTVar p new'-      y <- sun x a-      go y p+{-# SPECIALIZE shouldUpdate :: forall a b. Eq a => (b -> a -> JSM b) -> b -> TVar a -> JSM () #-}+shouldUpdate :: forall a b m. MonadJSM m => MonadUnliftIO m => Eq a => (b -> a -> m b) -> b -> TVar a -> m ()+shouldUpdate sun prev currentModel = do+  -- get the current state of the model+  sampleModel   :: a          <- readTVarIO currentModel+  -- duplicate that state so we can compare if the model changes+  previousModel :: TVar a     <- newTVarIO sampleModel+  -- store the accumulating value in a TVar so we can control when it updates+  currentState  :: TVar b     <- newTVarIO prev+  -- get the window once+  window        :: Window     <- currentWindowUnchecked+  -- get the execution context once+  context       :: UnliftIO m <- askUnliftIO +  let+    go :: [Int] -> m ()+    go frames = do +      -- block if the new model is the same as the old+      newModel <- atomically $ do+        new' <- readTVar currentModel+        old  <- readTVar previousModel+        -- if the new model is different from the old+        -- unblock and write the new model for the next comparision+        if new' == old then retry else new' <$ writeTVar previousModel new'++      -- if we already had something scheduled to run, cancel it+      traverse_ (clearTimeout window . Just) frames++      -- generate a callback for the request animation frame+      let callback = fun $ \_ _ _ -> do+             -- get the current state+             x <- readTVarIO currentState+             -- run the action against the current state, and the new model+             y <- liftIO $ unliftIO context $ sun x newModel+             -- write the new state for the next run+             atomically $ writeTVar currentState y+             -- note this means that @newModel@ updates for each call to @go@+             -- but @currentState@ only updates if the frame is actually called+             traverse_ (clearTimeout window . Just) frames++      -- schedule the action to run on the next frame+      frameId' <- setTimeout window callback Nothing++      go (frameId':frames)++  () <$ forkIO (go mempty)++ -- | A monad transformer for building up a Continuation in a series of steps in a monadic computation newtype ContinuationT model m a = ContinuationT   { runContinuationT :: m (a, Continuation m model) }@@ -370,15 +485,17 @@  -- | This adds the given Continuation to the Continuation being built up in the monadic context --   where this function is invoked.-commit :: Monad m => Continuation m model -> ContinuationT model m ()-commit = ContinuationT . return . ((),)+{-# SPECIALIZE commit :: Continuation JSM model -> ContinuationT model JSM () #-}+commit :: Applicative m => Continuation m model -> ContinuationT model m ()+commit = ContinuationT . pure . ((),)   -- | This turns a monadic computation to build up a Continuation into the Continuation which it --   represents. The actions inside the monadic computation will be run when the Continuation --   is run. The return value of the monadic computation will be discarded.-voidRunContinuationT :: Monad m => ContinuationT model m a -> Continuation m model-voidRunContinuationT m = Continuation . (id,) . const $ snd <$> runContinuationT m+{-# SPECIALIZE voidRunContinuationT :: ContinuationT model JSM a -> Continuation JSM model #-}+voidRunContinuationT :: Functor m => ContinuationT model m a -> Continuation m model+voidRunContinuationT m = kleisli . const $ snd <$> runContinuationT m   -- | This turns a function for building a Continuation in a monadic computation@@ -386,21 +503,22 @@ --   into a Continuation which reads the current state of the model, --   runs the resulting monadic computation, and runs the Continuation --   resulting from that computation.-kleisliT :: Monad m => (model -> ContinuationT model m a) -> Continuation m model-kleisliT f = kleisli $ \x -> return . voidRunContinuationT $ f x+{-# SPECIALIZE kleisliT :: (model -> ContinuationT model JSM a) -> Continuation JSM model #-}+kleisliT :: Applicative m => (model -> ContinuationT model m a) -> Continuation m model+kleisliT f = kleisli (pure . voidRunContinuationT . f)   instance Functor m => Functor (ContinuationT model m) where   fmap f = ContinuationT . fmap (first f) . runContinuationT  -instance Monad m => Applicative (ContinuationT model m) where+instance Applicative m => Applicative (ContinuationT model m) where   pure = ContinuationT . pure . (, done)    ft <*> xt = ContinuationT $ do-    (f, fc) <- runContinuationT ft-    (x, xc) <- runContinuationT xt-    return (f x, fc <> xc)+    (\(f, fc) (x, xc) -> (f x, fc <> xc))+      <$> runContinuationT ft+      <*> runContinuationT xt   instance Monad m => Monad (ContinuationT model m) where@@ -409,7 +527,7 @@   m >>= f = ContinuationT $ do     (x, g) <- runContinuationT m     (y, h) <- runContinuationT (f x)-    return (y, g <> h)+    return (y, g `before` h)   instance MonadTrans (ContinuationT model) where

@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE BangPatterns           #-} {-# LANGUAGE CPP                    #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FlexibleInstances      #-}@@ -24,23 +23,22 @@ -}  +{-# OPTIONS_GHC -Wno-unused-imports #-} module Shpadoinkle.Core (   -- * Base Types-  Html(..), Prop(..)+  Html(..), Prop(..), Props(..), fromProps, toProps   -- ** Prop Constructors   , dataProp, flagProp, textProp, listenerProp, bakedProp   -- *** Listeners   , listenRaw, listen, listenM, listenM_, listenC, listener   -- ** Html Constructors   , h, baked, text-  -- ** Html Lenses-  , props, children, name, textContent   -- ** Hoists   , hoistHtml, hoistProp   -- ** Catamorphisms   , cataH, cataProp   -- ** Utilities-  , mapProps, mapChildren, injectProps, eitherH+  , mapProps, injectProps, eitherH   -- * JSVal Wrappers   , RawNode(..), RawEvent(..)   -- * Backend Interface@@ -54,18 +52,18 @@   ) where  -import           Control.Arrow                 (second)+import           Control.Applicative           (liftA2) import qualified Control.Categorical.Functor   as F import           Control.Category              ((.)) import           Control.PseudoInverseCategory (EndoIso (..),                                                 HasHaskFunctors (fmapA),-                                                PIArrow (piendo, piiso, pisecond),+                                                PIArrow (piendo, piiso),                                                 PseudoInverseCategory (piinverse),                                                 ToHask (piapply))-import           Data.Functor.Identity         (Identity (Identity, runIdentity)) import           Data.Kind                     (Type)-import           Data.List                     (foldl')-import           Data.Map                      (alter, toList)+import           Data.Map                      as M (Map, foldl', insert,+                                                     mapEither, singleton,+                                                     toList, unionWithKey) import           Data.String                   (IsString (..)) import           Data.Text                     (Text, pack) import           GHCJS.DOM.Types               (JSM, MonadJSM, liftJSM)@@ -88,19 +86,14 @@ -- Please note, this is NOT the Virtual DOM used by Backend. -- This type backs a DSL that is then /interpreted/ into Virtual DOM -- by the Backend of your choosing. HTML comments are not supported.-data Html :: (Type -> Type) -> Type -> Type where-  -- | A standard node in the DOM tree-  Node :: Text -> [(Text, Prop m a)] -> [Html m a] -> Html m a-  -- | If you can bake an element into a 'RawNode' then you can embed it as a baked potato.-  -- Backend does not provide any state management or abstraction to deal with-  -- custom embedded content; it's on you to decide how and when this 'RawNode' will-  -- be updated. For example, if you wanted to embed a Google map as a baked potato,-  -- and you are driving your Backend view with a 'TVar', you would need to build-  -- the 'RawNode' for this map /outside/ of your Backend view and pass it in-  -- as an argument. The 'RawNode' is a reference you control.-  Potato :: JSM RawNode -> Html m a-  -- | The humble text node-  TextNode :: Text -> Html m a+-- This is Church encoded for performance reasons.+newtype Html m a = Html+  { unHtml+      :: forall r. (Text -> [(Text, Prop m a)] -> [r] -> r)+      -> (JSM (RawNode, STM (Continuation m a)) -> r)+      -> (Text -> r)+      -> r+  }   -- | Properties of a DOM node. Backend does not use attributes directly,@@ -129,47 +122,55 @@   PListener :: (RawNode -> RawEvent -> JSM (Continuation m a)) -> Prop m a  --- | Ensure all prop keys are unique.--- Collisions for Data, Text, Flags, and Potatoes are last write wins--- Collisions for Listeners are Continuation Semigroup operations-nubProps :: Monad m => Html m a -> Html m a-nubProps = mapPropsRecursive $ toList . foldl' f mempty-  where-  f acc (t,p) = alter (Just . g t p) t acc-  g k new old = case (new, old) of-    (PText t, Just (PText t')) | k == "className" -> PText $ t <> " " <> t'-    (PListener l, Just (PListener l')) -> PListener $-      \raw evt -> mappend <$> l raw evt <*> l' raw evt-    _ -> new---mapPropsRecursive :: ([(Text, Prop m a)] -> [(Text, Prop m a)]) -> Html m a -> Html m a-mapPropsRecursive f = \case-  Node t ps cs -> Node t (f ps) (mapPropsRecursive f <$> cs)-  x            -> x+instance Eq (Prop m a) where+  x == y = case (x,y) of+    (PText x', PText y') -> x' == y'+    (PFlag x', PFlag y') -> x' == y'+    _                    -> False   -- | Construct a listener from its name and a simple monadic event handler.-listenM :: Monad m => Text -> m (a -> a) -> (Text, Prop m a)+listenM :: Applicative m => Text -> m (a -> a) -> (Text, Prop m a) listenM k = listenC k . impur   -- | Construct a listener from its name and a simple stateless monadic event handler.-listenM_ :: Monad m => Text -> m () -> (Text, Prop m a)+listenM_ :: Applicative m => Text -> m () -> (Text, Prop m a) listenM_ k = listenC k . causes  --- | Type alias for convenience (typing out the nested brackets is tiresome)-type Props' m a = [(Text, Prop m a)]+newtype Props m a = Props { getProps :: Map Text (Prop m a) }  +{-# SPECIALIZE toProps :: [(Text, Prop JSM a)] -> Props JSM a #-}+toProps :: Applicative m => [(Text, Prop m a)] -> Props m a+toProps = foldMap $ Props . uncurry singleton+++fromProps :: Props m a -> [(Text, Prop m a)]+fromProps = M.toList . getProps+++instance Applicative m => Semigroup (Props m a) where+  Props xs <> Props ys = Props $ unionWithKey go xs ys+    where+      go k old new = case (old, new) of+        (PText t, PText t') | k == "className" -> PText (t <> " " <> t')+        (PText t, PText t') | k == "style"     -> PText (t <> "; " <> t')+        (PListener l, PListener l')            -> PListener $+           \raw evt -> mappend <$> l raw evt <*> l' raw evt+        _                                      -> new+++instance Applicative m => Monoid (Props m a) where+  mempty = Props mempty++ -- | If you can provide a Natural Transformation from one Functor to another -- then you may change the action of 'Html'.-hoistHtml :: Functor m => Functor n => (m ~> n) -> Html m a -> Html n a-hoistHtml f = \case-  Node t ps cs -> Node t (fmap (hoistProp f) <$> ps) (hoistHtml f <$> cs)-  Potato p     -> Potato p-  TextNode t   -> TextNode t+hoistHtml :: Functor m => (m ~> n) -> Html m a -> Html n a+hoistHtml f (Html h') = Html $ \n p t -> h'+  (\t' ps cs -> n t' (fmap (hoistProp f) <$> ps) cs) (p . fmap (fmap (fmap (hoist f)))) t {-# INLINE hoistHtml #-}  @@ -190,7 +191,7 @@ --   "hiya" = TextNode "hiya" -- @ instance IsString (Html m a) where-  fromString = TextNode . pack+  fromString = text . pack   {-# INLINE fromString #-}  @@ -205,7 +206,7 @@  -- | @Html m@ is a functor in the EndoIso category, where the objects are --   types and the morphisms are EndoIsos.-instance Monad m => F.Functor EndoIso EndoIso (Html m) where+instance Applicative m => F.Functor EndoIso EndoIso (Html m) where   map (EndoIso f g i) = EndoIso (mapC . piapply $ map' (piendo f))                                 (mapC . piapply $ map' (piiso g i))                                 (mapC . piapply $ map' (piiso i g))@@ -216,7 +217,7 @@  -- | Prop is a functor in the EndoIso category, where the objects are types --  and the morphisms are EndoIsos.-instance Monad m => F.Functor EndoIso EndoIso (Prop m) where+instance Applicative m => F.Functor EndoIso EndoIso (Prop m) where   map :: forall a b. EndoIso a b -> EndoIso (Prop m a) (Prop m b)   map f = EndoIso id mapFwd mapBack     where f' :: EndoIso (Continuation m a) (Continuation m b)@@ -242,28 +243,22 @@ -- | Given a lens, you can change the type of an Html by using the lens --   to convert the types of the Continuations inside it. instance Continuous Html where-  mapC f (Node t ps es) = Node t (unMapProps . mapC f $ MapProps ps) (mapC f <$> es)-  mapC _ (Potato p) = Potato p-  mapC _ (TextNode t) = TextNode t+  mapC f (Html h') = Html $ \n p t -> h' (\t' ps cs -> n t' (fmap (mapC f) <$> ps) cs)+         (p . fmap (fmap (fmap (mapC f)))) t   {-# INLINE mapC #-}  --- | Newtype to deal with the fact that we can't make the typeclass instances---   for Endofunctor EndoIso and Continuous using the Props type alias-newtype MapProps m a = MapProps { unMapProps :: Props' m a }-- -- | Props is a functor in the EndoIso category, where the objects are --  types and the morphisms are EndoIsos.-instance Monad m => F.Functor EndoIso EndoIso (MapProps m) where-  map f = piiso MapProps unMapProps . fmapA (pisecond (F.map f)) . piiso unMapProps MapProps+instance Applicative m => F.Functor EndoIso EndoIso (Props m) where+  map f = piiso Props getProps . fmapA (F.map f) . piiso getProps Props   {-# INLINE map #-}   -- | Given a lens, you can change the type of a Props by using the lens --   to convert the types of the Continuations inside.-instance Continuous MapProps where-  mapC f = MapProps . fmap (second (mapC f)) . unMapProps+instance Continuous Props where+  mapC f = Props . fmap (mapC f) . getProps   {-# INLINE mapC #-}  @@ -327,69 +322,34 @@  -- | Construct an HTML element JSX-style. h :: Text -> [(Text, Prop m a)] -> [Html m a] -> Html m a-h = Node+h t ps cs = Html $ \a b c -> a t ps ((\(Html h') -> h' a b c) <$> cs) {-# INLINE h #-}   -- | Construct a 'Potato' from a 'JSM' action producing a 'RawNode'.-baked :: JSM RawNode -> Html m a-baked = Potato+baked :: JSM (RawNode, STM (Continuation m a)) -> Html m a+baked jr = Html $ \_ p _ -> p jr {-# INLINE baked #-}   -- | Construct a text node. text :: Text -> Html m a-text = TextNode+text t = Html $ \_ _ f -> f t {-# INLINE text #-}  --- | Lens to props-props :: Applicative f => ([(Text, Prop m a)] -> f [(Text, Prop m a)]) -> Html m a -> f (Html m a)-props inj = \case-  Node t ps cs -> (\ps' -> Node t ps' cs) <$> inj ps-  t            -> pure t-{-# INLINE props #-}----- | Lens to children-children :: Applicative f => ([Html m a] -> f [Html m a]) -> Html m a -> f (Html m a)-children inj = \case-  Node t ps cs -> Node t ps <$> inj cs-  t            -> pure t-{-# INLINE children #-}----- | Lens to tag name-name :: Applicative f => (Text -> f Text) -> Html m a -> f (Html m a)-name inj = \case-  Node t ps cs -> (\t' -> Node t' ps cs) <$> inj t-  t            -> pure t-{-# INLINE name #-}----- | Lens to content of 'TextNode's-textContent :: Applicative f => (Text -> f Text) -> Html m a -> f (Html m a)-textContent inj = \case-  TextNode t -> TextNode <$> inj t-  n          -> pure n-{-# INLINE textContent #-}-- -- | Construct an HTML element out of heterogeneous alternatives.-eitherH :: Monad m => (a -> Html m a) -> (b -> Html m b) -> Either a b -> Html m (Either a b)+eitherH :: Applicative m => (a -> Html m a) -> (b -> Html m b) -> Either a b -> Html m (Either a b) eitherH = eitherC {-# INLINE eitherH #-}   -- | Fold an HTML element, i.e. transform an h-algebra into an h-catamorphism. cataH :: (Text -> [(Text, Prop m a)] -> [b] -> b)-      -> (JSM RawNode -> b)+      -> (JSM (RawNode, STM (Continuation m a)) -> b)       -> (Text -> b)       -> Html m a -> b-cataH f g h' = \case-  Node t ps cs -> f t ps (cataH f g h' <$> cs)-  Potato p     -> g p-  TextNode t   -> h' t+cataH f g h' (Html h'') = h'' f g h'   -- | Natural Transformation@@ -444,19 +404,13 @@  -- | Transform the properties of some Node. This has no effect on 'TextNode's or 'Potato'es. mapProps :: ([(Text, Prop m a)] -> [(Text, Prop m a)]) -> Html m a -> Html m a-mapProps f = runIdentity . props (Identity . f)+mapProps f (Html h') = Html $ \n p t -> h' (\t' ps cs -> n t' (f ps) cs) p t {-# INLINE mapProps #-}  --- | Transform the children of some Node. This has no effect on 'TextNode's or 'Potato'es.-mapChildren :: ([Html m a] -> [Html m a]) -> Html m a -> Html m a-mapChildren f = runIdentity . children (Identity . f)-{-# INLINE mapChildren #-}-- -- | Inject props into an existing 'Node'. injectProps :: [(Text, Prop m a)] -> Html m a -> Html m a-injectProps ps = mapProps (++ ps)+injectProps ps = mapProps (<> ps) {-# INLINE injectProps #-}  @@ -507,8 +461,6 @@   -- ^ How to get to JSM?   -> (TVar a -> b m ~> m)   -- ^ What backend are we running?-  -> a-  -- ^ What is the initial state?   -> TVar a   -- ^ How can we know when to update?   -> (a -> Html (b m) a)@@ -516,22 +468,18 @@   -> b m RawNode   -- ^ Where do we render?   -> JSM ()-shpadoinkle toJSM toM initial model view stage = do-  let-    j :: b m ~> JSM-    j = toJSM . toM model+shpadoinkle toJSM toM model view stage = setup @b @m @a $ do -    go :: RawNode -> VNode b m -> a -> JSM (VNode b m)-    go c n a = j $ do-      !m  <- interpret toJSM . nubProps $ view a-      patch c (Just n) m+  c <- j stage+  initial <- readTVarIO model+  n <- go c Nothing initial+  () <$ shouldUpdate (go c . Just) n model -  setup @b @m @a $ do-    (c,n) <- j $ do-      c <- stage-      n <- interpret toJSM . nubProps $ view initial-      _ <- patch c Nothing n-      return (c,n)-    _ <- shouldUpdate (go c) n model-    return ()+  where++  j :: b m ~> JSM+  j = toJSM . toM model++  go :: RawNode -> Maybe (VNode b m) -> a -> JSM (VNode b m)+  go c n a = j $ patch c n =<< interpret toJSM (view a) 

@@ -128,7 +128,7 @@   -> JSM () fullPage g f i view getStage = do   model <- newTVarIO i-  shpadoinkle g f i model view getStage+  shpadoinkle g f model view getStage {-# INLINE fullPage #-}