From 16ef8e6377cd89f1c9771e9858354fe6343974cf Mon Sep 17 00:00:00 2001 From: Morgan Thomas Date: Fri, 11 Jun 2021 00:01:28 -0400 Subject: [PATCH 1/7] shpadoinkle takes a continuation --- core/Shpadoinkle/Core.hs | 11 ++++++---- core/Shpadoinkle/Run.hs | 20 +++++++++++-------- developer-tools/Main.hs | 4 ++-- examples/Animation.hs | 3 ++- examples/TODOMVC.hs | 4 ++-- examples/ThrottleAndDebounce.hs | 4 ++-- examples/servant-crud/Client.hs | 6 +++--- examples/widgets/Widgets.hs | 4 ++-- router/Shpadoinkle/Router.hs | 16 ++++++++++----- .../Shpadoinkle/Website/Page/FourOhFour.hs | 3 ++- website/Shpadoinkle/Website/Run.hs | 7 +++++-- 11 files changed, 50 insertions(+), 32 deletions(-) diff --git a/core/Shpadoinkle/Core.hs b/core/Shpadoinkle/Core.hs index d0629f0a..deb045d6 100644 --- a/core/Shpadoinkle/Core.hs +++ b/core/Shpadoinkle/Core.hs @@ -71,9 +71,9 @@ import UnliftIO.STM (STM, TVar, atomically, readTVarIO, retrySTM, writeTVar) -import Shpadoinkle.Continuation (Continuation, Continuous (..), +import Shpadoinkle.Continuation (NFData, Continuation, Continuous (..), causes, eitherC, hoist, impur, - pur, shouldUpdate) + pur, shouldUpdate, writeUpdate) -- | This is the core type in Backend. @@ -407,24 +407,27 @@ class Backend b m a | b m -> a where -- and renders the Backend view to the page. shpadoinkle :: forall b m a - . Backend b m a => Monad (b m) => Eq a + . Backend b m a => Functor m => Monad (b m) => Eq a => NFData a => (m ~> JSM) -- ^ How to get to JSM? -> (TVar a -> b m ~> m) -- ^ What backend are we running? -> TVar a -- ^ How can we know when to update? + -> Continuation m a + -- ^ What should happen at first? -> (a -> Html (b m) a) -- ^ How should the HTML look? -> b m RawNode -- ^ Where do we render? -> JSM () -shpadoinkle toJSM toM model view stage = setup @b @m @a $ do +shpadoinkle toJSM toM model run view stage = setup @b @m @a $ do c <- j stage initial <- readTVarIO model n <- go c Nothing initial () <$ shouldUpdate (go c . Just) n model + writeUpdate model $ hoist toJSM run where diff --git a/core/Shpadoinkle/Run.hs b/core/Shpadoinkle/Run.hs index f05eae3a..a882637e 100644 --- a/core/Shpadoinkle/Run.hs +++ b/core/Shpadoinkle/Run.hs @@ -24,8 +24,8 @@ module Shpadoinkle.Run ( import Data.Text (Text) import GHCJS.DOM.Types (JSM) -import Shpadoinkle (Backend, Html, RawNode, - TVar, newTVarIO, +import Shpadoinkle (NFData, Continuation, Backend, Html, RawNode, + TVar, newTVarIO, done, shpadoinkle, type (~>)) @@ -114,21 +114,23 @@ type Port = Int -- | Wrapper around 'shpadoinkle' for full page apps -- that do not need outside control of the territory fullPage - :: Backend b m a => Monad (b m) => Eq a + :: Backend b m a => Functor m => Monad (b m) => Eq a => NFData a => (m ~> JSM) -- ^ How do we get to JSM? -> (TVar a -> b m ~> m) -- ^ What backend are we running? -> a -- ^ What is the initial state? + -> Continuation m a + -- ^ What happens at first? -> (a -> Html (b m) a) -- ^ How should the html look? -> b m RawNode -- ^ Where do we render? -> JSM () -fullPage g f i view getStage = do +fullPage g f i go view getStage = do model <- newTVarIO i - shpadoinkle g f model view getStage + shpadoinkle g f model go view getStage {-# INLINE fullPage #-} @@ -139,11 +141,13 @@ fullPage g f i view getStage = do -- This set of assumptions is extremely common when starting -- a new project. fullPageJSM - :: Backend b JSM a => Monad (b JSM) => Eq a + :: Backend b JSM a => Monad (b JSM) => Eq a => NFData a => (TVar a -> b JSM ~> JSM) -- ^ What backend are we running? -> a -- ^ What is the initial state? + -> Continuation JSM a + -- ^ What happens at first? -> (a -> Html (b JSM) a) -- ^ How should the html look? -> b JSM RawNode @@ -170,7 +174,7 @@ runJSorWarp = run -- -- (a good starting place) simple - :: Backend b JSM a => Monad (b JSM) => Eq a + :: Backend b JSM a => Monad (b JSM) => Eq a => NFData a => (TVar a -> b JSM ~> JSM) -- ^ What backend are we running? -> a @@ -180,7 +184,7 @@ simple -> b JSM RawNode -- ^ where do we render? -> JSM () -simple = fullPageJSM +simple model initial view stage = fullPageJSM model initial done view stage {-# INLINE simple #-} diff --git a/developer-tools/Main.hs b/developer-tools/Main.hs index ee14daec..b2347541 100644 --- a/developer-tools/Main.hs +++ b/developer-tools/Main.hs @@ -29,7 +29,7 @@ import UnliftIO (TVar, atomically, modifyTVar, newTVarIO) import Shpadoinkle (Html, NFData, flagProp, - shpadoinkle, text) + shpadoinkle, text, done) import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Html import Shpadoinkle.Run (runJSorWarp) @@ -152,7 +152,7 @@ app :: JSM () app = do model <- liftIO $ newTVarIO emptyModel listenForOutput model - shpadoinkle id runParDiff model panel getBody + shpadoinkle id runParDiff model done panel getBody main :: IO () diff --git a/examples/Animation.hs b/examples/Animation.hs index 32839af8..a8f3b153 100644 --- a/examples/Animation.hs +++ b/examples/Animation.hs @@ -18,6 +18,7 @@ import GHCJS.DOM.Window (Window, requestAnimationFrame) import Shpadoinkle (Html, JSM, TVar, newTVarIO, + done, shpadoinkle) import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage) import Shpadoinkle.Html as H (div, @@ -70,4 +71,4 @@ main = runJSorWarp 8080 $ do t <- newTVarIO 0 w <- currentWindowUnchecked _ <- forkIO $ threadDelay wait >> animation w t - shpadoinkle id runSnabbdom t view stage + shpadoinkle id runSnabbdom t done view stage diff --git a/examples/TODOMVC.hs b/examples/TODOMVC.hs index 7f29d109..e80e6ab7 100644 --- a/examples/TODOMVC.hs +++ b/examples/TODOMVC.hs @@ -17,7 +17,7 @@ import Data.String (IsString) import Data.Text hiding (count, filter, length) import GHC.Generics (Generic) import Prelude hiding (div, unwords) -import Shpadoinkle (Html, JSM, NFData, shpadoinkle, +import Shpadoinkle (Html, JSM, NFData, done, shpadoinkle, text) import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage) import Shpadoinkle.Html (a, addStyle, autofocus, button, @@ -214,7 +214,7 @@ app = do model <- manageLocalStorage "todo" emptyModel addStyle "https://cdn.jsdelivr.net/npm/todomvc-common@1.0.5/base.css" addStyle "https://cdn.jsdelivr.net/npm/todomvc-app-css@2.2.0/index.css" - shpadoinkle id runSnabbdom model view stage + shpadoinkle id runSnabbdom model done view stage main :: IO () diff --git a/examples/ThrottleAndDebounce.hs b/examples/ThrottleAndDebounce.hs index f60e1ee0..ef69b969 100644 --- a/examples/ThrottleAndDebounce.hs +++ b/examples/ThrottleAndDebounce.hs @@ -10,7 +10,7 @@ import Control.Arrow (first, second) import Control.Monad.IO.Class (liftIO) import Data.Text (Text, pack) import Shpadoinkle (Html, JSM, newTVarIO, shpadoinkle, - text) + done, text) import Shpadoinkle.Backend.ParDiff (ParDiffT, runParDiff) import Shpadoinkle.Html (Debounce (..), Throttle (..), button, debounce, div_, getBody, @@ -46,7 +46,7 @@ view (Control debouncer1 debouncer2 throttler1 throttler2) (count, txt) = div_ app :: Control App -> JSM () app control = do model <- liftIO $ newTVarIO initial - shpadoinkle id runParDiff model (view control) getBody + shpadoinkle id runParDiff model done (view control) getBody where initial = (0, "") diff --git a/examples/servant-crud/Client.hs b/examples/servant-crud/Client.hs index cf0156d1..d0e1ee4c 100644 --- a/examples/servant-crud/Client.hs +++ b/examples/servant-crud/Client.hs @@ -14,10 +14,10 @@ import Control.Monad.Reader (MonadIO) import Data.Proxy (Proxy (..)) #ifndef ghcjs_HOST_OS import Shpadoinkle (JSM, MonadJSM, MonadUnliftIO (..), - UnliftIO (..), askJSM, runJSM) + UnliftIO (..), askJSM, runJSM, done) #else import Shpadoinkle (JSM, MonadUnliftIO (..), - UnliftIO (..), askJSM, runJSM) + UnliftIO (..), askJSM, runJSM, done) #endif import Servant.API ((:<|>) (..)) import Shpadoinkle.Backend.ParDiff (runParDiff) @@ -55,4 +55,4 @@ instance CRUDSpaceCraft App where app :: JSM () -app = fullPageSPA @ (SPA JSM) runApp runParDiff (withHydration start) view getBody start routes +app = fullPageSPA @ (SPA JSM) runApp runParDiff (withHydration start) done view getBody start routes diff --git a/examples/widgets/Widgets.hs b/examples/widgets/Widgets.hs index 6d43f45a..c573b831 100644 --- a/examples/widgets/Widgets.hs +++ b/examples/widgets/Widgets.hs @@ -24,7 +24,7 @@ import GHC.Generics (Generic) import Prelude hiding (div) import Shpadoinkle (Html, JSM, MonadJSM, NFData, - liftJSM, newTVarIO, + liftJSM, newTVarIO, done, shpadoinkle) -- import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Backend.Snabbdom (runSnabbdom) @@ -114,7 +114,7 @@ initial = Model fullOptions (minBound `withOptions'` fullset) 4 app :: JSM () app = do model <- liftIO $ newTVarIO initial - shpadoinkle id runSnabbdom model view getBody + shpadoinkle id runSnabbdom model done view getBody main :: IO () diff --git a/router/Shpadoinkle/Router.hs b/router/Shpadoinkle/Router.hs index 6bf11de7..75e24f50 100644 --- a/router/Shpadoinkle/Router.hs +++ b/router/Shpadoinkle/Router.hs @@ -208,6 +208,8 @@ fullPageSPAC :: forall layout b a r m -- ^ What backend are we running? -> (r -> m a) -- ^ what is the initial state? + -> Continuation m a + -- ^ what should happen at first? -> (a -> Html (b m) a) -- ^ how should the html look? -> b m RawNode @@ -217,7 +219,7 @@ fullPageSPAC :: forall layout b a r m -> layout :>> r -- ^ how shall we relate urls to routes? -> JSM () -fullPageSPAC toJSM backend i' view getStage onRoute routes = do +fullPageSPAC toJSM backend i' go view getStage onRoute routes = do let router = route @layout @r routes window <- currentWindowUnchecked getRoute window router $ \case @@ -227,7 +229,7 @@ fullPageSPAC toJSM backend i' view getStage onRoute routes = do model <- newTVarIO i _ <- listenStateChange router $ writeUpdate model . kleisli . const . (fmap (hoist toJSM) . toJSM) . onRoute - shpadoinkle toJSM backend model view getStage + shpadoinkle toJSM backend model go view getStage syncPoint @@ -248,6 +250,8 @@ fullPageSPA :: forall layout b a r m -- ^ What backend are we running? -> (r -> m a) -- ^ what is the initial state? + -> Continuation m a + -- ^ what should happen at first? -> (a -> Html (b m) a) -- ^ how should the html look? -> b m RawNode @@ -257,7 +261,7 @@ fullPageSPA :: forall layout b a r m -> layout :>> r -- ^ how shall we relate urls to routes? -> JSM () -fullPageSPA a b c v g s = fullPageSPAC @layout a b c v g (fmap (pur . const) . s) +fullPageSPA a b c d v g s = fullPageSPAC @layout a b c d v g (fmap (pur . const) . s) -- | This method wraps @shpadoinkle@ providing for a convenient entrypoint @@ -280,6 +284,8 @@ fullPageSPA' :: forall layout b a r m -- ^ where do we store the state? -> (r -> m a) -- ^ what is the initial state? + -> Continuation m a + -- ^ what should happen at first? -> (a -> Html (b m) a) -- ^ how should the html look? -> b m RawNode @@ -289,7 +295,7 @@ fullPageSPA' :: forall layout b a r m -> layout :>> r -- ^ how shall we relate urls to routes? -> JSM () -fullPageSPA' toJSM backend model i' view getStage onRoute routes = do +fullPageSPA' toJSM backend model i' go view getStage onRoute routes = do let router = route @layout @r routes window <- currentWindowUnchecked getRoute window router $ \case @@ -299,7 +305,7 @@ fullPageSPA' toJSM backend model i' view getStage onRoute routes = do atomically $ writeTVar model i _ <- listenStateChange router $ writeUpdate model . kleisli . const . (fmap (hoist toJSM) . toJSM) . onRoute - shpadoinkle toJSM backend model view getStage + shpadoinkle toJSM backend model go view getStage syncPoint diff --git a/website/Shpadoinkle/Website/Page/FourOhFour.hs b/website/Shpadoinkle/Website/Page/FourOhFour.hs index dbbc0b96..42bae128 100644 --- a/website/Shpadoinkle/Website/Page/FourOhFour.hs +++ b/website/Shpadoinkle/Website/Page/FourOhFour.hs @@ -35,6 +35,7 @@ import Language.Javascript.JSaddle (toJSVal) import Shpadoinkle (JSM, NFData, RawNode (..), newTVarIO, + done, shpadoinkle) import Shpadoinkle.Backend.Snabbdom (runSnabbdom) import Shpadoinkle.Html as H @@ -167,7 +168,7 @@ play = do _ <- requestAnimationFrame win =<< animate win model raw <- RawNode <$> toJSVal elm _ <- forkIO $ threadDelay 1 - >> shpadoinkle id runSnabbdom model game (pure raw) + >> shpadoinkle id runSnabbdom model done game (pure raw) return raw diff --git a/website/Shpadoinkle/Website/Run.hs b/website/Shpadoinkle/Website/Run.hs index 012b6e9d..0094873a 100644 --- a/website/Shpadoinkle/Website/Run.hs +++ b/website/Shpadoinkle/Website/Run.hs @@ -27,13 +27,15 @@ import Shpadoinkle (JSM, MonadJSM, MonadUnliftIO (..), TVar, constUpdate, liftJSM, - newTVarIO) + newTVarIO, + done) #else import Shpadoinkle (JSM, MonadUnliftIO (..), TVar, constUpdate, liftJSM, - newTVarIO) + newTVarIO, + done) #endif import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage) @@ -130,6 +132,7 @@ app = do runSnabbdom model (withHydration (startJS model)) + done (view yc) stage (fmap constUpdate . startJS model) routes -- GitLab From db3259c152033ebf13393665a8115f8db85b6d20 Mon Sep 17 00:00:00 2001 From: Morgan Thomas Date: Fri, 11 Jun 2021 00:39:31 -0400 Subject: [PATCH 2/7] clock example --- examples/Clock.hs | 41 +++++++++++++++++++ examples/Shpadoinkle-examples.cabal | 16 ++++++++ .../Shpadoinkle/Website/Page/FourOhFour.hs | 3 +- website/Shpadoinkle/Website/Run.hs | 10 ++--- 4 files changed, 62 insertions(+), 8 deletions(-) create mode 100644 examples/Clock.hs diff --git a/examples/Clock.hs b/examples/Clock.hs new file mode 100644 index 00000000..c15b9759 --- /dev/null +++ b/examples/Clock.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Main where + + +import Prelude hiding (span) + +import Control.Concurrent (threadDelay) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Data.Text (pack) +import Shpadoinkle (Html, Continuation, JSM, voidRunContinuationT, commit, merge, pur, text, newTVarIO, shpadoinkle) +import Shpadoinkle.Html (div_, h2_, span, id', getBody) +import Shpadoinkle.Run (runJSorWarp) +import Shpadoinkle.Backend.ParDiff (runParDiff) + + +view :: Int -> Html m Int +view time = div_ + [ h2_ [ "Clock Example" ] + , "The current time is: " + , span [ id' "out" ] [ text . pack $ "T+" <> show time <> " seconds" ] + ] + + +clock :: Continuation JSM Int +clock = voidRunContinuationT $ do + lift . liftIO $ threadDelay 1000000 + commit $ pur (+1) + commit $ merge clock + + +app :: JSM () +app = do + model <- newTVarIO 0 + shpadoinkle id runParDiff model clock view getBody + + +main :: IO () +main = runJSorWarp 8080 app diff --git a/examples/Shpadoinkle-examples.cabal b/examples/Shpadoinkle-examples.cabal index 3971d7fb..fb6db087 100644 --- a/examples/Shpadoinkle-examples.cabal +++ b/examples/Shpadoinkle-examples.cabal @@ -109,6 +109,22 @@ executable calculator-ie default-language: Haskell2010 +executable clock + import: ghc-options, ghcjs-options + + main-is: Clock.hs + + hs-source-dirs: ./. + + build-depends: + Shpadoinkle + , Shpadoinkle-backend-pardiff + , Shpadoinkle-html + , base >=4.12.0 && <4.16 + , text + , transformers + + executable counter import: ghc-options, ghcjs-options diff --git a/website/Shpadoinkle/Website/Page/FourOhFour.hs b/website/Shpadoinkle/Website/Page/FourOhFour.hs index 42bae128..4666689a 100644 --- a/website/Shpadoinkle/Website/Page/FourOhFour.hs +++ b/website/Shpadoinkle/Website/Page/FourOhFour.hs @@ -33,9 +33,8 @@ import GHCJS.DOM.Window (Window, requestAnimationFrame) import Language.Javascript.JSaddle (toJSVal) import Shpadoinkle (JSM, NFData, - RawNode (..), + RawNode (..), done, newTVarIO, - done, shpadoinkle) import Shpadoinkle.Backend.Snabbdom (runSnabbdom) import Shpadoinkle.Html as H diff --git a/website/Shpadoinkle/Website/Run.hs b/website/Shpadoinkle/Website/Run.hs index 0094873a..5779cfd9 100644 --- a/website/Shpadoinkle/Website/Run.hs +++ b/website/Shpadoinkle/Website/Run.hs @@ -26,16 +26,14 @@ import Servant.Server as Servant (serve) import Shpadoinkle (JSM, MonadJSM, MonadUnliftIO (..), TVar, constUpdate, - liftJSM, - newTVarIO, - done) + done, liftJSM, + newTVarIO) #else import Shpadoinkle (JSM, MonadUnliftIO (..), TVar, constUpdate, - liftJSM, - newTVarIO, - done) + done, liftJSM, + newTVarIO) #endif import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage) -- GitLab From 19553290add1f10d0f209997dce79623dcf977a8 Mon Sep 17 00:00:00 2001 From: Morgan Thomas Date: Fri, 11 Jun 2021 00:45:59 -0400 Subject: [PATCH 3/7] refactor --- examples/Clock.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/examples/Clock.hs b/examples/Clock.hs index c15b9759..bf262524 100644 --- a/examples/Clock.hs +++ b/examples/Clock.hs @@ -11,7 +11,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Data.Text (pack) import Shpadoinkle (Html, Continuation, JSM, voidRunContinuationT, commit, merge, pur, text, newTVarIO, shpadoinkle) -import Shpadoinkle.Html (div_, h2_, span, id', getBody) +import Shpadoinkle.Html (div_, h2_, getBody) import Shpadoinkle.Run (runJSorWarp) import Shpadoinkle.Backend.ParDiff (runParDiff) @@ -19,8 +19,9 @@ import Shpadoinkle.Backend.ParDiff (runParDiff) view :: Int -> Html m Int view time = div_ [ h2_ [ "Clock Example" ] - , "The current time is: " - , span [ id' "out" ] [ text . pack $ "T+" <> show time <> " seconds" ] + , "The current time is T+" + , text . pack $ show time + , " seconds" ] -- GitLab From 8cc50e719509717445c1427b864a1abcf370c70c Mon Sep 17 00:00:00 2001 From: Morgan Thomas Date: Fri, 11 Jun 2021 01:54:12 -0400 Subject: [PATCH 4/7] wip time based process composition example --- examples/ClockWithAttentionModal.hs | 113 ++++++++++++++++++++++++++++ examples/Shpadoinkle-examples.cabal | 16 ++++ 2 files changed, 129 insertions(+) create mode 100644 examples/ClockWithAttentionModal.hs diff --git a/examples/ClockWithAttentionModal.hs b/examples/ClockWithAttentionModal.hs new file mode 100644 index 00000000..89a0b5bb --- /dev/null +++ b/examples/ClockWithAttentionModal.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + + +module Main where + + +import Prelude hiding (div) + +import Control.Concurrent (threadDelay) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Data.Text (pack) +import GHC.Generics (Generic) +import Shpadoinkle (NFData, MonadJSM, Html, Continuation, JSM, liftC, voidRunContinuationT, commit, merge, pur, text, newTVarIO, shpadoinkle) +import Shpadoinkle.Html (div, div_, h2_, button, getBody, onClickC, onGlobalKeyDownC, onGlobalKeyUpC) +import Shpadoinkle.Run (runJSorWarp) +import Shpadoinkle.Backend.ParDiff (runParDiff) + + +newtype Seconds = Seconds Int + deriving newtype (Eq, Ord, Show, Num) + deriving (Generic, NFData) + + +newtype Clock = Clock { unClock :: Seconds } + deriving newtype (Eq, Ord, Show, Num) + deriving (Generic, NFData) + + +newtype Idle = Idle { unIdle :: Seconds } + deriving newtype (Eq, Ord, Show, Num) + deriving Generic + +instance NFData Idle + + +data Model = Model { getClock :: Clock, getIdle :: Idle } + deriving (Eq, Show, Generic) + +instance NFData Model + + +clockC :: Functor m => Continuation m Clock -> Continuation m Model +clockC = liftC (\c (Model _ i) -> Model c i) getClock + + +idleC :: Functor m => Continuation m Idle -> Continuation m Model +idleC = liftC (\i (Model c _) -> Model c i) getIdle + + +clockView :: Clock -> Html m a +clockView (Clock time) = div_ + [ h2_ [ "Clock / Attention Example" ] + , "The current time is T+" + , text . pack $ show time + , " seconds" + ] + + +idleView :: Functor m => Html m Model +idleView = + div + [ onGlobalKeyDownC (const attention) + , onGlobalKeyUpC (const attention) + ] + [ h2_ [ "Clock / Attention Example" ] + , "Are you paying attention?" + , div_ [ button [ onClickC attention ] [ "Yes" ] ] + , div_ [ button [ onClickC attention ] [ "No" ] ] + ] + + +idleThreshold :: Seconds +idleThreshold = 5 + + +view :: Functor m => Model -> Html m Model +view (Model clockTime (Idle idleTime)) = + if idleTime > idleThreshold + then idleView + else clockView clockTime + + +incrementEachSecond :: Num a => MonadJSM m => Continuation m a +incrementEachSecond = voidRunContinuationT $ do + lift . liftIO $ threadDelay 1000000 + commit $ pur (+1) + commit $ merge incrementEachSecond + + +clock :: MonadJSM m => Continuation m Model +clock = clockC incrementEachSecond + + +idle :: MonadJSM m => Continuation m Model +idle = idleC incrementEachSecond + + +attention :: Functor m => Continuation m Model +attention = idleC (pur (const 0)) + + +app :: JSM () +app = do + model <- newTVarIO (Model (Clock 0) (Idle 0)) + shpadoinkle id runParDiff model (clock <> idle) view getBody + + +main :: IO () +main = runJSorWarp 8080 app diff --git a/examples/Shpadoinkle-examples.cabal b/examples/Shpadoinkle-examples.cabal index fb6db087..97a6bbaf 100644 --- a/examples/Shpadoinkle-examples.cabal +++ b/examples/Shpadoinkle-examples.cabal @@ -125,6 +125,22 @@ executable clock , transformers +executable clock-with-attention-modal + import: ghc-options, ghcjs-options + + main-is: ClockWithAttentionModal.hs + + hs-source-dirs: ./. + + build-depends: + Shpadoinkle + , Shpadoinkle-backend-pardiff + , Shpadoinkle-html + , base >=4.12.0 && <4.16 + , text + , transformers + + executable counter import: ghc-options, ghcjs-options -- GitLab From 4c3b1d89f653e5dccb7ee79d0c7604f814f67f48 Mon Sep 17 00:00:00 2001 From: Morgan Thomas Date: Fri, 11 Jun 2021 02:50:44 -0400 Subject: [PATCH 5/7] wip fork continuations --- core/Shpadoinkle/Continuation.hs | 75 +++++++++++++++++++------------- 1 file changed, 45 insertions(+), 30 deletions(-) diff --git a/core/Shpadoinkle/Continuation.hs b/core/Shpadoinkle/Continuation.hs index df430cd9..b83b03f7 100644 --- a/core/Shpadoinkle/Continuation.hs +++ b/core/Shpadoinkle/Continuation.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -19,7 +20,7 @@ module Shpadoinkle.Continuation ( -- * The Continuation Type Continuation (..) , runContinuation - , done, pur, impur, kleisli, causes, causedBy, merge, contIso, before, after + , done, pur, impur, kleisli, causes, causedBy, merge, contIso, before, after, meanwhile -- * The Class , Continuous (..) -- ** Hoist @@ -74,6 +75,10 @@ import UnliftIO.Concurrent (forkIO) -- updates generated so far but allows for further state updates to be generated based on -- further monadic IO computation. -- +-- A Continuation may Fork, which causes it to split into two separately and concurrently +-- running continuations. The left hand side continuation is a continuation of whatever +-- continuation the fork occurs inside of. +-- -- The functions generating each stage of the Continuation -- are called with states which reflect the current state of the app, with all -- the pure state updating functions generated so far having been @@ -85,7 +90,7 @@ data Continuation m a = Continuation (a -> a) (a -> m (Continuation m a)) | Rollback (Continuation m a) | Merge (Continuation m a) | Pure (a -> a) - + | Fork (Continuation m a) (Continuation m a) -- | A pure state updating function can be turned into a Continuation. This function @@ -137,12 +142,19 @@ 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 +Fork f g `before` h = (f `before` h) `meanwhile` g +f `before` (Fork g h) = (f `before` g) `meanwhile` h after :: Applicative m => Continuation m a -> Continuation m a -> Continuation m a after = flip before +-- | Runs two continuations in parallel. +meanwhile :: Continuation m a -> Continuation m a -> Continuation m a +meanwhile = Fork + + -- | '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 @@ -151,6 +163,8 @@ after = flip before -- 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. +-- +-- 'runContinuation' does not execute forks concurrently; instead, it executes them serially. {-# SPECIALIZE runContinuation :: Continuation JSM a -> a -> JSM (a -> a) #-} runContinuation :: Monad m => Continuation m a -> a -> m (a -> a) runContinuation = runContinuation' id @@ -164,6 +178,7 @@ runContinuation' f (Continuation g h) x = do runContinuation' _ (Rollback f) x = runContinuation' id f x runContinuation' f (Merge g) x = runContinuation' f g x runContinuation' f (Pure g) _ = return (g.f) +runContinuation' f (Fork g h) x = runContinuation' f (g `before` h) x -- | @f@ is a Functor to Hask from the category where the objects are @@ -179,19 +194,21 @@ instance Continuous Continuation where -- | 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 (Merge g) = Merge (hoist f g) +hoist _ (Pure f) = Pure f +hoist f (Rollback r) = Rollback (hoist f r) +hoist f (Merge g) = Merge (hoist f g) hoist f (Continuation g h) = Continuation g $ \x -> f $ hoist f <$> h x +hoist f (Fork g h) = Fork (hoist f g) (hoist f h) -- | 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 (Merge h) = Merge (liftC' f g h) +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)) +liftC' f g (Fork h i) = Fork (liftC' f g h) (liftC' f g i) -- | Apply a traversal inside a Continuation to change the Continuation's type. @@ -200,6 +217,7 @@ liftCMay' :: Applicative m => (a -> b -> b) -> (b -> Maybe a) -> Continuation m 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 (Merge h) = Merge (liftCMay' f g h) +liftCMay' f g (Fork h i) = Fork (liftCMay' f g h) (liftCMay' f g i) 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) @@ -265,9 +283,10 @@ 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' (Merge f) = Merge (maybeC' f) +maybeC' (Pure f) = Pure (fmap f) +maybeC' (Rollback r) = Rollback (maybeC' r) +maybeC' (Merge f) = Merge (maybeC' f) +maybeC' (Fork f g) = Fork (maybeC' f) (maybeC' g) maybeC' (Continuation f g) = Continuation (fmap f) $ \case Just x -> maybeC' <$> g x @@ -292,9 +311,10 @@ comaybe f x = fromMaybe x . f $ Just x -- 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' (Merge f) = Merge (comaybeC' f) +comaybeC' (Pure f) = Pure (comaybe f) +comaybeC' (Rollback r) = Rollback (comaybeC' r) +comaybeC' (Merge f) = Merge (comaybeC' f) +comaybeC' (Fork f g) = Fork (comaybeC' f) (comaybeC' g) comaybeC' (Continuation f g) = Continuation (comaybe f) ( fmap comaybeC' . g . Just) @@ -323,12 +343,13 @@ mapRight f (Right x) = Right (f x) -- completes than it was when the Continuation started, then the -- coproduct Continuation will have no effect on the state. {-# 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' :: forall m a b. 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 -> pure (Pure (mapLeft h)) Rollback r -> pure . Rollback $ eitherC' r done Merge h -> pure . Merge $ eitherC' h done + Fork h i -> pure $ Fork (eitherC' h done) (eitherC' i done) Continuation h i -> (\j -> Continuation (mapLeft h) ( const . pure $ eitherC' j (Rollback done))) <$> i x @@ -336,6 +357,7 @@ eitherC' f g = Continuation id $ \case Pure h -> pure (Pure (mapRight h)) Rollback r -> pure . Rollback $ eitherC' done r Merge h -> pure . Merge $ eitherC' done h + Fork h i -> pure $ Fork (eitherC' done h) (eitherC' done i) Continuation h i -> (\j -> Continuation (mapRight h) (const . pure $ eitherC' (Rollback done) j)) <$> i x @@ -358,6 +380,7 @@ contIso :: Functor m => (a -> b) -> (b -> a) -> Continuation m a -> Continuation 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 (Merge h) = Merge (contIso f g h) +contIso f g (Fork h i) = Fork (contIso f g h) (contIso f g i) contIso f g (Pure h) = Pure (f.h.g) @@ -368,21 +391,7 @@ contIso f g (Pure h) = Pure (f.h.g) -- 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 (pure (Rollback g))) - (Rollback f) <> (Pure _) = Rollback f - (Merge f) <> g = Merge (f <> g) - f <> (Merge g) = Merge (f <> g) - + (<>) = meanwhile -- | Since combining Continuations homogeneously is an associative operation, -- and this operation has a unit element (done), Continuations are a 'Monoid'. @@ -401,6 +410,9 @@ writeUpdate' h model f = do Merge g -> do atomically $ writeTVar model . h =<< readTVar model writeUpdate' id model (const (return g)) + Fork g j -> do + void . forkIO $ writeUpdate' id model (const (return j)) + writeUpdate' h model (const (return g)) Rollback gs -> writeUpdate' id model (const (return gs)) @@ -413,6 +425,9 @@ writeUpdate model = \case Continuation f g -> void . forkIO $ writeUpdate' f model g Pure f -> atomically (writeTVar model . f =<< readTVar model) Merge f -> writeUpdate model f + Fork g h -> + do void . forkIO $ writeUpdate model g + writeUpdate model h Rollback f -> writeUpdate model f -- GitLab From 39b6223e8932ba2fb2f52735684cb2e140f8a166 Mon Sep 17 00:00:00 2001 From: Morgan Thomas Date: Fri, 11 Jun 2021 13:35:48 -0400 Subject: [PATCH 6/7] remove keypress event handlers --- examples/ClockWithAttentionModal.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/examples/ClockWithAttentionModal.hs b/examples/ClockWithAttentionModal.hs index 89a0b5bb..2950e14a 100644 --- a/examples/ClockWithAttentionModal.hs +++ b/examples/ClockWithAttentionModal.hs @@ -15,7 +15,7 @@ import Control.Monad.Trans.Class (lift) import Data.Text (pack) import GHC.Generics (Generic) import Shpadoinkle (NFData, MonadJSM, Html, Continuation, JSM, liftC, voidRunContinuationT, commit, merge, pur, text, newTVarIO, shpadoinkle) -import Shpadoinkle.Html (div, div_, h2_, button, getBody, onClickC, onGlobalKeyDownC, onGlobalKeyUpC) +import Shpadoinkle.Html (div_, h2_, button, getBody, onClickC) import Shpadoinkle.Run (runJSorWarp) import Shpadoinkle.Backend.ParDiff (runParDiff) @@ -62,10 +62,7 @@ clockView (Clock time) = div_ idleView :: Functor m => Html m Model idleView = - div - [ onGlobalKeyDownC (const attention) - , onGlobalKeyUpC (const attention) - ] + div_ [ h2_ [ "Clock / Attention Example" ] , "Are you paying attention?" , div_ [ button [ onClickC attention ] [ "Yes" ] ] -- GitLab From 5c0acdf0bcc7308f26acf9141b256aae8c074740 Mon Sep 17 00:00:00 2001 From: Morgan Thomas Date: Fri, 11 Jun 2021 13:50:17 -0400 Subject: [PATCH 7/7] Revert "shpadoinkle takes a continuation" This reverts commit 16ef8e6377cd89f1c9771e9858354fe6343974cf. --- core/Shpadoinkle/Core.hs | 11 ++++------ core/Shpadoinkle/Run.hs | 20 ++++++++----------- developer-tools/Main.hs | 4 ++-- examples/Animation.hs | 3 +-- examples/Clock.hs | 5 +++-- examples/ClockWithAttentionModal.hs | 5 +++-- examples/TODOMVC.hs | 4 ++-- examples/ThrottleAndDebounce.hs | 4 ++-- examples/servant-crud/Client.hs | 6 +++--- examples/widgets/Widgets.hs | 4 ++-- router/Shpadoinkle/Router.hs | 16 +++++---------- .../Shpadoinkle/Website/Page/FourOhFour.hs | 4 ++-- website/Shpadoinkle/Website/Run.hs | 5 ++--- 13 files changed, 39 insertions(+), 52 deletions(-) diff --git a/core/Shpadoinkle/Core.hs b/core/Shpadoinkle/Core.hs index deb045d6..d0629f0a 100644 --- a/core/Shpadoinkle/Core.hs +++ b/core/Shpadoinkle/Core.hs @@ -71,9 +71,9 @@ import UnliftIO.STM (STM, TVar, atomically, readTVarIO, retrySTM, writeTVar) -import Shpadoinkle.Continuation (NFData, Continuation, Continuous (..), +import Shpadoinkle.Continuation (Continuation, Continuous (..), causes, eitherC, hoist, impur, - pur, shouldUpdate, writeUpdate) + pur, shouldUpdate) -- | This is the core type in Backend. @@ -407,27 +407,24 @@ class Backend b m a | b m -> a where -- and renders the Backend view to the page. shpadoinkle :: forall b m a - . Backend b m a => Functor m => Monad (b m) => Eq a => NFData a + . Backend b m a => Monad (b m) => Eq a => (m ~> JSM) -- ^ How to get to JSM? -> (TVar a -> b m ~> m) -- ^ What backend are we running? -> TVar a -- ^ How can we know when to update? - -> Continuation m a - -- ^ What should happen at first? -> (a -> Html (b m) a) -- ^ How should the HTML look? -> b m RawNode -- ^ Where do we render? -> JSM () -shpadoinkle toJSM toM model run view stage = setup @b @m @a $ do +shpadoinkle toJSM toM model view stage = setup @b @m @a $ do c <- j stage initial <- readTVarIO model n <- go c Nothing initial () <$ shouldUpdate (go c . Just) n model - writeUpdate model $ hoist toJSM run where diff --git a/core/Shpadoinkle/Run.hs b/core/Shpadoinkle/Run.hs index a882637e..f05eae3a 100644 --- a/core/Shpadoinkle/Run.hs +++ b/core/Shpadoinkle/Run.hs @@ -24,8 +24,8 @@ module Shpadoinkle.Run ( import Data.Text (Text) import GHCJS.DOM.Types (JSM) -import Shpadoinkle (NFData, Continuation, Backend, Html, RawNode, - TVar, newTVarIO, done, +import Shpadoinkle (Backend, Html, RawNode, + TVar, newTVarIO, shpadoinkle, type (~>)) @@ -114,23 +114,21 @@ type Port = Int -- | Wrapper around 'shpadoinkle' for full page apps -- that do not need outside control of the territory fullPage - :: Backend b m a => Functor m => Monad (b m) => Eq a => NFData a + :: Backend b m a => Monad (b m) => Eq a => (m ~> JSM) -- ^ How do we get to JSM? -> (TVar a -> b m ~> m) -- ^ What backend are we running? -> a -- ^ What is the initial state? - -> Continuation m a - -- ^ What happens at first? -> (a -> Html (b m) a) -- ^ How should the html look? -> b m RawNode -- ^ Where do we render? -> JSM () -fullPage g f i go view getStage = do +fullPage g f i view getStage = do model <- newTVarIO i - shpadoinkle g f model go view getStage + shpadoinkle g f model view getStage {-# INLINE fullPage #-} @@ -141,13 +139,11 @@ fullPage g f i go view getStage = do -- This set of assumptions is extremely common when starting -- a new project. fullPageJSM - :: Backend b JSM a => Monad (b JSM) => Eq a => NFData a + :: Backend b JSM a => Monad (b JSM) => Eq a => (TVar a -> b JSM ~> JSM) -- ^ What backend are we running? -> a -- ^ What is the initial state? - -> Continuation JSM a - -- ^ What happens at first? -> (a -> Html (b JSM) a) -- ^ How should the html look? -> b JSM RawNode @@ -174,7 +170,7 @@ runJSorWarp = run -- -- (a good starting place) simple - :: Backend b JSM a => Monad (b JSM) => Eq a => NFData a + :: Backend b JSM a => Monad (b JSM) => Eq a => (TVar a -> b JSM ~> JSM) -- ^ What backend are we running? -> a @@ -184,7 +180,7 @@ simple -> b JSM RawNode -- ^ where do we render? -> JSM () -simple model initial view stage = fullPageJSM model initial done view stage +simple = fullPageJSM {-# INLINE simple #-} diff --git a/developer-tools/Main.hs b/developer-tools/Main.hs index b2347541..ee14daec 100644 --- a/developer-tools/Main.hs +++ b/developer-tools/Main.hs @@ -29,7 +29,7 @@ import UnliftIO (TVar, atomically, modifyTVar, newTVarIO) import Shpadoinkle (Html, NFData, flagProp, - shpadoinkle, text, done) + shpadoinkle, text) import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Html import Shpadoinkle.Run (runJSorWarp) @@ -152,7 +152,7 @@ app :: JSM () app = do model <- liftIO $ newTVarIO emptyModel listenForOutput model - shpadoinkle id runParDiff model done panel getBody + shpadoinkle id runParDiff model panel getBody main :: IO () diff --git a/examples/Animation.hs b/examples/Animation.hs index a8f3b153..32839af8 100644 --- a/examples/Animation.hs +++ b/examples/Animation.hs @@ -18,7 +18,6 @@ import GHCJS.DOM.Window (Window, requestAnimationFrame) import Shpadoinkle (Html, JSM, TVar, newTVarIO, - done, shpadoinkle) import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage) import Shpadoinkle.Html as H (div, @@ -71,4 +70,4 @@ main = runJSorWarp 8080 $ do t <- newTVarIO 0 w <- currentWindowUnchecked _ <- forkIO $ threadDelay wait >> animation w t - shpadoinkle id runSnabbdom t done view stage + shpadoinkle id runSnabbdom t view stage diff --git a/examples/Clock.hs b/examples/Clock.hs index bf262524..c214c40b 100644 --- a/examples/Clock.hs +++ b/examples/Clock.hs @@ -10,7 +10,7 @@ import Control.Concurrent (threadDelay) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Data.Text (pack) -import Shpadoinkle (Html, Continuation, JSM, voidRunContinuationT, commit, merge, pur, text, newTVarIO, shpadoinkle) +import Shpadoinkle (Html, Continuation, JSM, voidRunContinuationT, commit, merge, pur, text, newTVarIO, shpadoinkle, writeUpdate) import Shpadoinkle.Html (div_, h2_, getBody) import Shpadoinkle.Run (runJSorWarp) import Shpadoinkle.Backend.ParDiff (runParDiff) @@ -35,7 +35,8 @@ clock = voidRunContinuationT $ do app :: JSM () app = do model <- newTVarIO 0 - shpadoinkle id runParDiff model clock view getBody + writeUpdate model clock + shpadoinkle id runParDiff model view getBody main :: IO () diff --git a/examples/ClockWithAttentionModal.hs b/examples/ClockWithAttentionModal.hs index 2950e14a..b66537bc 100644 --- a/examples/ClockWithAttentionModal.hs +++ b/examples/ClockWithAttentionModal.hs @@ -14,7 +14,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Data.Text (pack) import GHC.Generics (Generic) -import Shpadoinkle (NFData, MonadJSM, Html, Continuation, JSM, liftC, voidRunContinuationT, commit, merge, pur, text, newTVarIO, shpadoinkle) +import Shpadoinkle (NFData, MonadJSM, Html, Continuation, JSM, liftC, voidRunContinuationT, commit, merge, pur, text, newTVarIO, shpadoinkle, writeUpdate) import Shpadoinkle.Html (div_, h2_, button, getBody, onClickC) import Shpadoinkle.Run (runJSorWarp) import Shpadoinkle.Backend.ParDiff (runParDiff) @@ -103,7 +103,8 @@ attention = idleC (pur (const 0)) app :: JSM () app = do model <- newTVarIO (Model (Clock 0) (Idle 0)) - shpadoinkle id runParDiff model (clock <> idle) view getBody + writeUpdate model (clock <> idle) + shpadoinkle id runParDiff model view getBody main :: IO () diff --git a/examples/TODOMVC.hs b/examples/TODOMVC.hs index e80e6ab7..7f29d109 100644 --- a/examples/TODOMVC.hs +++ b/examples/TODOMVC.hs @@ -17,7 +17,7 @@ import Data.String (IsString) import Data.Text hiding (count, filter, length) import GHC.Generics (Generic) import Prelude hiding (div, unwords) -import Shpadoinkle (Html, JSM, NFData, done, shpadoinkle, +import Shpadoinkle (Html, JSM, NFData, shpadoinkle, text) import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage) import Shpadoinkle.Html (a, addStyle, autofocus, button, @@ -214,7 +214,7 @@ app = do model <- manageLocalStorage "todo" emptyModel addStyle "https://cdn.jsdelivr.net/npm/todomvc-common@1.0.5/base.css" addStyle "https://cdn.jsdelivr.net/npm/todomvc-app-css@2.2.0/index.css" - shpadoinkle id runSnabbdom model done view stage + shpadoinkle id runSnabbdom model view stage main :: IO () diff --git a/examples/ThrottleAndDebounce.hs b/examples/ThrottleAndDebounce.hs index ef69b969..f60e1ee0 100644 --- a/examples/ThrottleAndDebounce.hs +++ b/examples/ThrottleAndDebounce.hs @@ -10,7 +10,7 @@ import Control.Arrow (first, second) import Control.Monad.IO.Class (liftIO) import Data.Text (Text, pack) import Shpadoinkle (Html, JSM, newTVarIO, shpadoinkle, - done, text) + text) import Shpadoinkle.Backend.ParDiff (ParDiffT, runParDiff) import Shpadoinkle.Html (Debounce (..), Throttle (..), button, debounce, div_, getBody, @@ -46,7 +46,7 @@ view (Control debouncer1 debouncer2 throttler1 throttler2) (count, txt) = div_ app :: Control App -> JSM () app control = do model <- liftIO $ newTVarIO initial - shpadoinkle id runParDiff model done (view control) getBody + shpadoinkle id runParDiff model (view control) getBody where initial = (0, "") diff --git a/examples/servant-crud/Client.hs b/examples/servant-crud/Client.hs index d0e1ee4c..cf0156d1 100644 --- a/examples/servant-crud/Client.hs +++ b/examples/servant-crud/Client.hs @@ -14,10 +14,10 @@ import Control.Monad.Reader (MonadIO) import Data.Proxy (Proxy (..)) #ifndef ghcjs_HOST_OS import Shpadoinkle (JSM, MonadJSM, MonadUnliftIO (..), - UnliftIO (..), askJSM, runJSM, done) + UnliftIO (..), askJSM, runJSM) #else import Shpadoinkle (JSM, MonadUnliftIO (..), - UnliftIO (..), askJSM, runJSM, done) + UnliftIO (..), askJSM, runJSM) #endif import Servant.API ((:<|>) (..)) import Shpadoinkle.Backend.ParDiff (runParDiff) @@ -55,4 +55,4 @@ instance CRUDSpaceCraft App where app :: JSM () -app = fullPageSPA @ (SPA JSM) runApp runParDiff (withHydration start) done view getBody start routes +app = fullPageSPA @ (SPA JSM) runApp runParDiff (withHydration start) view getBody start routes diff --git a/examples/widgets/Widgets.hs b/examples/widgets/Widgets.hs index c573b831..6d43f45a 100644 --- a/examples/widgets/Widgets.hs +++ b/examples/widgets/Widgets.hs @@ -24,7 +24,7 @@ import GHC.Generics (Generic) import Prelude hiding (div) import Shpadoinkle (Html, JSM, MonadJSM, NFData, - liftJSM, newTVarIO, done, + liftJSM, newTVarIO, shpadoinkle) -- import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Backend.Snabbdom (runSnabbdom) @@ -114,7 +114,7 @@ initial = Model fullOptions (minBound `withOptions'` fullset) 4 app :: JSM () app = do model <- liftIO $ newTVarIO initial - shpadoinkle id runSnabbdom model done view getBody + shpadoinkle id runSnabbdom model view getBody main :: IO () diff --git a/router/Shpadoinkle/Router.hs b/router/Shpadoinkle/Router.hs index 75e24f50..6bf11de7 100644 --- a/router/Shpadoinkle/Router.hs +++ b/router/Shpadoinkle/Router.hs @@ -208,8 +208,6 @@ fullPageSPAC :: forall layout b a r m -- ^ What backend are we running? -> (r -> m a) -- ^ what is the initial state? - -> Continuation m a - -- ^ what should happen at first? -> (a -> Html (b m) a) -- ^ how should the html look? -> b m RawNode @@ -219,7 +217,7 @@ fullPageSPAC :: forall layout b a r m -> layout :>> r -- ^ how shall we relate urls to routes? -> JSM () -fullPageSPAC toJSM backend i' go view getStage onRoute routes = do +fullPageSPAC toJSM backend i' view getStage onRoute routes = do let router = route @layout @r routes window <- currentWindowUnchecked getRoute window router $ \case @@ -229,7 +227,7 @@ fullPageSPAC toJSM backend i' go view getStage onRoute routes = do model <- newTVarIO i _ <- listenStateChange router $ writeUpdate model . kleisli . const . (fmap (hoist toJSM) . toJSM) . onRoute - shpadoinkle toJSM backend model go view getStage + shpadoinkle toJSM backend model view getStage syncPoint @@ -250,8 +248,6 @@ fullPageSPA :: forall layout b a r m -- ^ What backend are we running? -> (r -> m a) -- ^ what is the initial state? - -> Continuation m a - -- ^ what should happen at first? -> (a -> Html (b m) a) -- ^ how should the html look? -> b m RawNode @@ -261,7 +257,7 @@ fullPageSPA :: forall layout b a r m -> layout :>> r -- ^ how shall we relate urls to routes? -> JSM () -fullPageSPA a b c d v g s = fullPageSPAC @layout a b c d v g (fmap (pur . const) . s) +fullPageSPA a b c v g s = fullPageSPAC @layout a b c v g (fmap (pur . const) . s) -- | This method wraps @shpadoinkle@ providing for a convenient entrypoint @@ -284,8 +280,6 @@ fullPageSPA' :: forall layout b a r m -- ^ where do we store the state? -> (r -> m a) -- ^ what is the initial state? - -> Continuation m a - -- ^ what should happen at first? -> (a -> Html (b m) a) -- ^ how should the html look? -> b m RawNode @@ -295,7 +289,7 @@ fullPageSPA' :: forall layout b a r m -> layout :>> r -- ^ how shall we relate urls to routes? -> JSM () -fullPageSPA' toJSM backend model i' go view getStage onRoute routes = do +fullPageSPA' toJSM backend model i' view getStage onRoute routes = do let router = route @layout @r routes window <- currentWindowUnchecked getRoute window router $ \case @@ -305,7 +299,7 @@ fullPageSPA' toJSM backend model i' go view getStage onRoute routes = do atomically $ writeTVar model i _ <- listenStateChange router $ writeUpdate model . kleisli . const . (fmap (hoist toJSM) . toJSM) . onRoute - shpadoinkle toJSM backend model go view getStage + shpadoinkle toJSM backend model view getStage syncPoint diff --git a/website/Shpadoinkle/Website/Page/FourOhFour.hs b/website/Shpadoinkle/Website/Page/FourOhFour.hs index 4666689a..dbbc0b96 100644 --- a/website/Shpadoinkle/Website/Page/FourOhFour.hs +++ b/website/Shpadoinkle/Website/Page/FourOhFour.hs @@ -33,7 +33,7 @@ import GHCJS.DOM.Window (Window, requestAnimationFrame) import Language.Javascript.JSaddle (toJSVal) import Shpadoinkle (JSM, NFData, - RawNode (..), done, + RawNode (..), newTVarIO, shpadoinkle) import Shpadoinkle.Backend.Snabbdom (runSnabbdom) @@ -167,7 +167,7 @@ play = do _ <- requestAnimationFrame win =<< animate win model raw <- RawNode <$> toJSVal elm _ <- forkIO $ threadDelay 1 - >> shpadoinkle id runSnabbdom model done game (pure raw) + >> shpadoinkle id runSnabbdom model game (pure raw) return raw diff --git a/website/Shpadoinkle/Website/Run.hs b/website/Shpadoinkle/Website/Run.hs index 5779cfd9..012b6e9d 100644 --- a/website/Shpadoinkle/Website/Run.hs +++ b/website/Shpadoinkle/Website/Run.hs @@ -26,13 +26,13 @@ import Servant.Server as Servant (serve) import Shpadoinkle (JSM, MonadJSM, MonadUnliftIO (..), TVar, constUpdate, - done, liftJSM, + liftJSM, newTVarIO) #else import Shpadoinkle (JSM, MonadUnliftIO (..), TVar, constUpdate, - done, liftJSM, + liftJSM, newTVarIO) #endif import Shpadoinkle.Backend.Snabbdom (runSnabbdom, @@ -130,7 +130,6 @@ app = do runSnabbdom model (withHydration (startJS model)) - done (view yc) stage (fmap constUpdate . startJS model) routes -- GitLab