From 16ef8e6377cd89f1c9771e9858354fe6343974cf Mon Sep 17 00:00:00 2001 From: Morgan Thomas Date: Fri, 11 Jun 2021 00:01:28 -0400 Subject: [PATCH] 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