From 10d2c1fa21abc7da94e8dc2127516533534ab2d6 Mon Sep 17 00:00:00 2001 From: Isaac Shapira Date: Sat, 27 Feb 2021 09:19:11 -0700 Subject: [PATCH 1/7] dep --- core/Shpadoinkle/Core.hs | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/core/Shpadoinkle/Core.hs b/core/Shpadoinkle/Core.hs index d4c17070..292330c0 100644 --- a/core/Shpadoinkle/Core.hs +++ b/core/Shpadoinkle/Core.hs @@ -44,6 +44,7 @@ module Shpadoinkle.Core ( -- * Backend Interface , Backend (..) , type (~>) + , Dependency(..) -- * The Shpadoinkle Primitive , shpadoinkle -- * Re-Exports @@ -59,7 +60,7 @@ import Control.PseudoInverseCategory (EndoIso (..), PIArrow (piendo, piiso), PseudoInverseCategory (piinverse), ToHask (piapply)) -import Data.Kind (Type) +import Data.Kind (Constraint, Type) import Data.Map as M (Map, singleton, toList, unionWithKey) import Data.String (IsString (..)) @@ -88,6 +89,7 @@ import Shpadoinkle.Continuation (Continuation, Continuous (..), newtype Html m a = Html { unHtml :: forall r. (Text -> Props m a -> [r] -> r) + -> (Dependency -> r -> r) -> (JSM RawNode -> r) -> (Text -> r) -> r @@ -318,19 +320,25 @@ cataProp d t f l p = \case -- | Construct an HTML element JSX-style. h :: Applicative m => Text -> [(Text, Prop m a)] -> [Html m a] -> Html m a -h t ps cs = Html $ \a b c -> a t (toProps ps) ((\(Html h') -> h' a b c) <$> cs) +h t ps cs = Html $ \a d b c -> a t (toProps ps) ((\(Html h') -> h' a d b c) <$> cs) {-# INLINE h #-} +-- | Memoed +depending :: forall b m a c. Requirments b m => (a -> Html m c) -> (a -> Html m c) +depending f x = Html $ \a d b c -> d (Dependency @b @m x) + $ case f x of Html h' -> h' a d b c + + -- | Construct a 'Potato' from a 'JSM' action producing a 'RawNode'. baked :: JSM RawNode -> Html m a -baked jr = Html $ \_ p _ -> p jr +baked jr = Html $ \_ _ p _ -> p jr {-# INLINE baked #-} -- | Construct a text node. text :: Text -> Html m a -text t = Html $ \_ _ f -> f t +text t = Html $ \_ _ _ f -> f t {-# INLINE text #-} @@ -342,10 +350,11 @@ eitherH = eitherC -- | Fold an HTML element, i.e. transform an h-algebra into an h-catamorphism. cataH :: (Text -> [(Text, Prop m a)] -> [b] -> b) + -> (Dependency -> b -> b) -> (JSM RawNode -> b) -> (Text -> b) -> Html m a -> b -cataH f g h' (Html h'') = h'' (\t ps cs -> f t (fromProps ps) cs) g h' +cataH f d g h' (Html h'') = h'' (\t ps cs -> f t (fromProps ps) cs) d g h' -- | Natural Transformation @@ -410,15 +419,19 @@ injectProps ps = mapProps (<> toProps ps) {-# INLINE injectProps #-} +data Dependency = forall b m a. Requirments b m => Dependency a + + -- | The Backend class describes a backend that can render 'Html'. -- Backends are generally Monad Transformers @b@ over some Monad @m@. -- -- prop> patch raw Nothing >=> patch raw Nothing = patch raw Nothing class Backend b m a | b m -> a where + type Requirments b m :: Constraint -- | VNode type family allows backends to have their own Virtual DOM. -- As such we can change out the rendering of our Backend view -- with new backends without updating our view logic. - type VNode b m + type VNode b m :: Type -- | A backend must be able to interpret 'Html' into its own internal Virtual DOM. interpret :: (m ~> JSM) -- GitLab From c8bb1970bec87f8d366dfddddc7533a9bb2681ec Mon Sep 17 00:00:00 2001 From: Isaac Shapira Date: Sat, 27 Feb 2021 14:06:14 -0700 Subject: [PATCH 2/7] hmmm --- .../pardiff/Shpadoinkle/Backend/ParDiff.hs | 77 +++++++++++++------ .../snabbdom/Shpadoinkle/Backend/Snabbdom.hs | 4 +- backends/static/Shpadoinkle/Backend/Static.hs | 4 +- core/Shpadoinkle/Core.hs | 34 ++++---- examples/TODOMVC.hs | 25 +++--- examples/package.yaml | 1 + html/Shpadoinkle/Html/Memo.hs | 53 +++++++------ 7 files changed, 124 insertions(+), 74 deletions(-) diff --git a/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs b/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs index c61aa601..9f625333 100644 --- a/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs +++ b/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs @@ -45,6 +45,7 @@ module Shpadoinkle.Backend.ParDiff import Control.Applicative (Alternative) +import Control.Compactable (traverseMaybe) import Control.Monad (forM_, void, when) import Control.Monad.Base (MonadBase (..), liftBaseDefault) import Control.Monad.Catch (MonadCatch, MonadThrow) @@ -64,8 +65,9 @@ import Data.Monoid ((<>)) import Data.Once (Once, newOnce, runOnce) import Data.Text (Text, intercalate) import Language.Javascript.JSaddle (FromJSVal (fromJSValUnchecked), - JSString, MakeObject (makeObject), - Object, ToJSString (toJSString), + JSString, JSVal, + MakeObject (makeObject), Object, + ToJSString (toJSString), ToJSVal (toJSVal), eval, fun, jsFalse, jsTrue, jsg, jsg2, liftJSM, unsafeSetProp, @@ -77,9 +79,9 @@ import UnliftIO.Concurrent (forkIO) import UnliftIO.STM (STM, atomically) import Shpadoinkle (Backend (..), Continuation, - Html (..), JSM, MonadJSM, NFData, - Prop (..), Props (..), - RawEvent (RawEvent), + Dependency (..), Html (..), JSM, + MonadJSM, NFData, Prop (..), + Props (..), RawEvent (RawEvent), RawNode (RawNode, unRawNode), fromProps, hoist, type (~>), writeUpdate) @@ -139,9 +141,12 @@ data ParVNode :: Type -> Type where ParNode :: Once JSM RawNode -> {-# UNPACK #-} !Text -> ParVProps a -> [ParVNode a] -> ParVNode a ParPotato :: Once JSM RawNode -> ParVNode a ParTextNode :: Once JSM RawNode -> {-# UNPACK #-} !Text -> ParVNode a + ParDepend :: !Dependency -> ParVNode a -> ParVNode a + type ParVProps = Props JSM + type ParVProp = Prop JSM @@ -184,11 +189,12 @@ setListener i m o k = do unsafeSetProp ("on" <> k) f o -getRaw :: ParVNode a -> Once JSM RawNode +getRaw :: ParVNode a -> Maybe (Once JSM RawNode) getRaw = \case - ParNode mk _ _ _ -> mk - ParPotato mk -> mk - ParTextNode mk _ -> mk + ParNode mk _ _ _ -> Just mk + ParPotato mk -> Just mk + ParTextNode mk _ -> Just mk + ParDepend _ _ -> Nothing makeProp :: Monad m => (m ~> JSM) -> TVar a -> Prop (ParDiffT a m) a -> ParVProp a @@ -294,14 +300,20 @@ patchChildren => NFData a => RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT a m [ParVNode a] patchChildren (RawNode p) [] new = liftJSM $ do - forM_ new $ \newChild -> do - RawNode cRaw <- runOnce (getRaw newChild) - p # "appendChild" $ cRaw + forM_ new $ \newChild -> + case getRaw newChild of + Nothing -> pure () + Just ronce -> do + RawNode cRaw <- runOnce ronce + _ <- p # "appendChild" $ cRaw + pure () pure new patchChildren _ old [] = liftJSM $ do doc <- jsg "document" tmp <- doc # "createElement" $ "div" - old' <- traverse (fmap unRawNode . runOnce . getRaw) old + old' :: [JSVal] <- traverseMaybe (\x -> case getRaw x of + Just once -> Just . unRawNode <$> runOnce once + Nothing -> pure Nothing) old void (tmp # "replaceChildren" $ old') void (tmp # "remove" $ ()) pure [] @@ -343,13 +355,22 @@ patch' parent old new = do cs'' <- patchChildren raw' cs cs' return $ ParNode raw name ps' cs'' + (ParDepend dep html, ParDepend dep' _) + | dep == dep' -> pure $ ParDepend dep html + + (ParDepend _ html, ParDepend _ html') -> + patch' parent html html' + -- node definitely has changed _ -> liftJSM $ do let RawNode p = parent - RawNode r <- runOnce $ getRaw old - RawNode c <- runOnce $ getRaw new - _ <- p # "replaceChild" $ (c, r) - return new + case (,) <$> getRaw old <*> getRaw new of + Nothing -> return new + Just (mold, mnew) -> do + RawNode r <- runOnce mold + RawNode c <- runOnce mnew + _ <- p # "replaceChild" $ (c, r) + return new interpret' @@ -357,7 +378,7 @@ interpret' . MonadJSM m => NFData a => (m ~> JSM) -> Html (ParDiffT a m) a -> ParDiffT a m (ParVNode a) -interpret' toJSM (Html h') = h' mkNode mkPotato mkText +interpret' toJSM (Html h') = h' mkNode mkDep mkPotato mkText where mkNode :: Text -> Props (ParDiffT a m) a -> [ParDiffT a m (ParVNode a)] -> ParDiffT a m (ParVNode a) mkNode name ps cs = do @@ -367,15 +388,21 @@ interpret' toJSM (Html h') = h' mkNode mkPotato mkText doc <- jsg "document" raw' <- doc # "createElement" $ name props toJSM i ps (RawNode raw') - forM_ cs' $ \c -> do - RawNode cRaw <- runOnce (getRaw c) - raw' # "appendChild" $ cRaw + forM_ cs' $ \c -> case getRaw c of + Nothing -> pure () + Just monce -> do + RawNode cRaw <- runOnce monce + _ <- raw' # "appendChild" $ cRaw + pure () return (RawNode raw') let p = Props (makeProp toJSM i <$> getProps ps) return $ ParNode raw name p cs' + mkDep :: Dependency -> ParDiffT a m (ParVNode a) -> ParDiffT a m (ParVNode a) + mkDep d pd = ParDepend d <$> pd + mkPotato :: JSM RawNode -> ParDiffT a m (ParVNode a) mkPotato = fmap ParPotato . liftJSM . newOnce @@ -400,8 +427,12 @@ instance Nothing -> liftJSM $ do let RawNode p = parent - RawNode c <- runOnce (getRaw new) - _ <- p # "appendChild" $ c + case getRaw new of + Nothing -> pure () + Just monce -> do + RawNode c <- runOnce monce + _ <- p # "appendChild" $ c + pure () return new Just old -> patch' parent old new diff --git a/backends/snabbdom/Shpadoinkle/Backend/Snabbdom.hs b/backends/snabbdom/Shpadoinkle/Backend/Snabbdom.hs index be5ef61f..31710c73 100644 --- a/backends/snabbdom/Shpadoinkle/Backend/Snabbdom.hs +++ b/backends/snabbdom/Shpadoinkle/Backend/Snabbdom.hs @@ -30,7 +30,7 @@ module Shpadoinkle.Backend.Snabbdom ) where -import Control.Category ((.)) +import Control.Category (id, (.)) import Control.Monad.Base (MonadBase (..), liftBaseDefault) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Reader (MonadIO, MonadReader (..), @@ -186,6 +186,8 @@ instance (MonadJSM m, NFData a) => Backend (SnabbdomT a) m a where o <- props toJSM i $ fromProps ps jsg3 "vnode" name o cs >>= fromJSValUnchecked) + (const id) + (\mrn -> liftJSM $ do o <- create hook <- create diff --git a/backends/static/Shpadoinkle/Backend/Static.hs b/backends/static/Shpadoinkle/Backend/Static.hs index 04083b65..91a3fdbd 100644 --- a/backends/static/Shpadoinkle/Backend/Static.hs +++ b/backends/static/Shpadoinkle/Backend/Static.hs @@ -14,12 +14,12 @@ import Control.Compactable (Compactable (fmapMaybe)) import Data.Monoid (mconcat, (<>)) import Data.Text (Text, null, unwords) -import Shpadoinkle (Html, Prop (PText), cataH, cataProp) +import Shpadoinkle (Html, Prop (PText), cataHtml, cataProp) -- | Render as @Text@ renderStatic :: Html m a -> Text -renderStatic = cataH renderTag (const mempty) id +renderStatic = cataHtml renderTag (const id) (const mempty) id renderTag :: Text -> [(Text, Prop m a)] -> [Text] -> Text diff --git a/core/Shpadoinkle/Core.hs b/core/Shpadoinkle/Core.hs index 292330c0..19916397 100644 --- a/core/Shpadoinkle/Core.hs +++ b/core/Shpadoinkle/Core.hs @@ -32,11 +32,11 @@ module Shpadoinkle.Core ( -- *** Listeners , listenRaw, listen, listenM, listenM_, listenC, listener -- ** Html Constructors - , h, baked, text + , h, baked, text, depending -- ** Hoists , hoistHtml, hoistProp -- ** Catamorphisms - , cataH, cataProp + , cataHtml, cataProp -- ** Utilities , mapProps, injectProps, eitherH -- * JSVal Wrappers @@ -60,11 +60,12 @@ import Control.PseudoInverseCategory (EndoIso (..), PIArrow (piendo, piiso), PseudoInverseCategory (piinverse), ToHask (piapply)) -import Data.Kind (Constraint, Type) +import Data.Kind (Type) import Data.Map as M (Map, singleton, toList, unionWithKey) import Data.String (IsString (..)) import Data.Text (Text, pack) +import Data.Typeable (Typeable, cast) import GHCJS.DOM.Types (JSM, MonadJSM, liftJSM) import Language.Javascript.JSaddle (FromJSVal (..), JSVal, ToJSVal (..), askJSM, runJSM) @@ -325,8 +326,8 @@ h t ps cs = Html $ \a d b c -> a t (toProps ps) ((\(Html h') -> h' a d b c) <$> -- | Memoed -depending :: forall b m a c. Requirments b m => (a -> Html m c) -> (a -> Html m c) -depending f x = Html $ \a d b c -> d (Dependency @b @m x) +depending :: (Eq a, Show a, Typeable a) => (a -> Html m c) -> (a -> Html m c) +depending f x = Html $ \a d b c -> d (Dependency x) $ case f x of Html h' -> h' a d b c @@ -349,12 +350,12 @@ eitherH = eitherC -- | Fold an HTML element, i.e. transform an h-algebra into an h-catamorphism. -cataH :: (Text -> [(Text, Prop m a)] -> [b] -> b) - -> (Dependency -> b -> b) - -> (JSM RawNode -> b) - -> (Text -> b) - -> Html m a -> b -cataH f d g h' (Html h'') = h'' (\t ps cs -> f t (fromProps ps) cs) d g h' +cataHtml :: (Text -> [(Text, Prop m a)] -> [r] -> r) + -> (Dependency -> r -> r) + -> (JSM RawNode -> r) + -> (Text -> r) + -> Html m a -> r +cataHtml f d g h' (Html h'') = h'' (\t ps cs -> f t (fromProps ps) cs) d g h' -- | Natural Transformation @@ -419,7 +420,15 @@ injectProps ps = mapProps (<> toProps ps) {-# INLINE injectProps #-} -data Dependency = forall b m a. Requirments b m => Dependency a +data Dependency = forall a. (Eq a, Show a, Typeable a) => Dependency !a + + +instance Eq Dependency where + Dependency l == Dependency r = cast l == Just r + + +instance Show Dependency where + show (Dependency x) = "Dependency (" ++ show x ++ ")" -- | The Backend class describes a backend that can render 'Html'. @@ -427,7 +436,6 @@ data Dependency = forall b m a. Requirments b m => Dependency a -- -- prop> patch raw Nothing >=> patch raw Nothing = patch raw Nothing class Backend b m a | b m -> a where - type Requirments b m :: Constraint -- | VNode type family allows backends to have their own Virtual DOM. -- As such we can change out the rendering of our Backend view -- with new backends without updating our view logic. diff --git a/examples/TODOMVC.hs b/examples/TODOMVC.hs index bacd934a..2b0cdf5e 100644 --- a/examples/TODOMVC.hs +++ b/examples/TODOMVC.hs @@ -15,11 +15,12 @@ import Control.Lens hiding (view) import Data.Generics.Labels () import Data.String (IsString) import Data.Text hiding (count, filter, length) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Prelude hiding (div, unwords) import Shpadoinkle (Html, JSM, NFData, readTVarIO, shpadoinkle, text) -import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage) +import Shpadoinkle.Backend.ParDiff (runParDiff, stage) import Shpadoinkle.Html (a, addStyle, autofocus, button, button', checked, class', div, div_, footer, for', form, h1_, @@ -39,24 +40,24 @@ default (Text) newtype Description = Description { unDescription :: Text } - deriving stock Generic deriving newtype (Show, Read, Eq, IsString) deriving anyclass NFData + deriving stock (Generic, Typeable) deriving newtype (Show, Read, Eq, IsString) deriving anyclass NFData newtype TaskId = TaskId { unTaskId :: Int } - deriving stock Generic deriving newtype (Show, Read, Eq, Ord, Num) deriving anyclass NFData + deriving stock (Generic, Typeable) deriving newtype (Show, Read, Eq, Ord, Num) deriving anyclass NFData data Completed = Complete | Incomplete - deriving (Generic, Show, Read, Eq, NFData) + deriving (Generic, Typeable, Show, Read, Eq, NFData) data Visibility = All | Active | Completed - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, NFData) + deriving (Generic, Typeable, Show, Read, Eq, Ord, Enum, Bounded, NFData) data Task = Task { description :: Description , completed :: Completed , taskId :: TaskId - } deriving (Generic, Show, Read, Eq, NFData) + } deriving (Generic, Typeable, Show, Read, Eq, NFData) data Model = Model @@ -64,7 +65,7 @@ data Model = Model , editing :: Maybe TaskId , visibility :: Visibility , current :: Description - } deriving (Generic, Show, Read, Eq, NFData) + } deriving (Generic, Typeable, Show, Read, Eq, NFData) emptyModel :: Model @@ -129,11 +130,11 @@ htmlIfTasks :: Model -> [Html m a] -> [Html m a] htmlIfTasks m h' = if Prelude.null (tasks m) then [] else h' -taskView :: Applicative m => Model -> Task -> Html m Model -taskView m = memo $ \(Task (Description d) c tid) -> +taskView :: Applicative m => Maybe TaskId -> Task -> Html m Model +taskView = memo $ \currentEdit (Task (Description d) c tid) -> li [ id' . pack . show $ unTaskId tid , class' [ ("completed", c == Complete) - , ("editing", Just tid == editing m) + , ("editing", Just tid == currentEdit) ] ] [ div "view" @@ -187,7 +188,7 @@ newTaskForm model = form [ class' "todo-form", onSubmit appendItem ] todoList :: Applicative m => Model -> Html m Model -todoList model = ul "todo-list" $ taskView model <$> visibility model `toVisible` tasks model +todoList model = ul "todo-list" $ taskView (editing model) <$> visibility model `toVisible` tasks model toggleAllBtn :: Applicative m => [Html m Model] @@ -216,7 +217,7 @@ app = do initial <- readTVarIO model 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 initial model view stage + shpadoinkle id runParDiff initial model view stage main :: IO () diff --git a/examples/package.yaml b/examples/package.yaml index 82684227..710f5193 100644 --- a/examples/package.yaml +++ b/examples/package.yaml @@ -58,6 +58,7 @@ executables: - Shpadoinkle-html - Shpadoinkle-lens - Shpadoinkle-backend-snabbdom + - Shpadoinkle-backend-pardiff lens: main: Lens.hs diff --git a/html/Shpadoinkle/Html/Memo.hs b/html/Shpadoinkle/Html/Memo.hs index 713e98e4..d72b2788 100644 --- a/html/Shpadoinkle/Html/Memo.hs +++ b/html/Shpadoinkle/Html/Memo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} @@ -16,34 +17,40 @@ module Shpadoinkle.Html.Memo ( Memo (..) -- * Uniadic , memo1, memo2, memo3, memo4, memo5, memo6, memo7, memo8, memo9 - -- * Custom Equality + -- * Custom Deuality , memo1', memo2', memo3', memo4', memo5', memo6', memo7', memo8', memo9' ) where import Data.IORef +import Data.Typeable +import Shpadoinkle (Html, depending) import System.IO.Unsafe + +type De a = (Eq a, Typeable a, Show a) + + {-| Variadic ditzy memoizer that only recalls at most one thing. prop> memo = id -} class Memo f where memo :: f -> f -instance Eq a => Memo (a -> b) where memo = memo1 -instance {-# OVERLAPS #-} (Eq a, Eq b) => Memo (a -> b -> c) where memo = memo2 -instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c) => Memo (a -> b -> c -> d) where memo = memo3 -instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d) => Memo (a -> b -> c -> d -> e) where memo = memo4 -instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d, Eq e) => Memo (a -> b -> c -> d -> e -> f) where memo = memo5 -instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => Memo (a -> b -> c -> d -> e -> f -> g) where memo = memo6 -instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Memo (a -> b -> c -> d -> e -> f -> g -> h) where memo = memo7 -instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h) => Memo (a -> b -> c -> d -> e -> f -> g -> h -> i) where memo = memo8 -instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i) => Memo (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) where memo = memo9 +instance De a => Memo (a -> Html m b) where memo = memo1 +instance {-# OVERLAPS #-} (De a, De b) => Memo (a -> b -> Html m c) where memo = memo2 +instance {-# OVERLAPS #-} (De a, De b, De c) => Memo (a -> b -> c -> Html m d) where memo = memo3 +instance {-# OVERLAPS #-} (De a, De b, De c, De d) => Memo (a -> b -> c -> d -> Html m e) where memo = memo4 +instance {-# OVERLAPS #-} (De a, De b, De c, De d, De e) => Memo (a -> b -> c -> d -> e -> Html m f) where memo = memo5 +instance {-# OVERLAPS #-} (De a, De b, De c, De d, De e, De f) => Memo (a -> b -> c -> d -> e -> f -> Html m g) where memo = memo6 +instance {-# OVERLAPS #-} (De a, De b, De c, De d, De e, De f, De g) => Memo (a -> b -> c -> d -> e -> f -> g -> Html m h) where memo = memo7 +instance {-# OVERLAPS #-} (De a, De b, De c, De d, De e, De f, De g, De h) => Memo (a -> b -> c -> d -> e -> f -> g -> h -> Html m i) where memo = memo8 +instance {-# OVERLAPS #-} (De a, De b, De c, De d, De e, De f, De g, De h, De i) => Memo (a -> b -> c -> d -> e -> f -> g -> h -> i -> Html m j) where memo = memo9 memo1' e f a = unsafePerformIO $ do - r <- newIORef (a, f a) - return $ applyEq e f r a + r <- newIORef (a, depending f a) + return $ applyDe e f r a memo2' e f a b = memo1' e (uncurry f) (a,b) memo3' e f a b c = memo1' e (uncurry2 f) (a,b,c) memo4' e f a b c d = memo1' e (uncurry3 f) (a,b,c,d) @@ -53,15 +60,15 @@ memo7' e f a b c d g h i = memo1' e (uncurry6 f) (a,b,c,d,g,h,i) memo8' e f a b c d g h i j = memo1' e (uncurry7 f) (a,b,c,d,g,h,i,j) memo9' e f a b c d g h i j k = memo1' e (uncurry8 f) (a,b,c,d,g,h,i,j,k) -memo1 :: Eq a => (a -> b) -> a -> b -memo2 :: Eq a => Eq b => (a -> b -> c) -> a -> b -> c -memo3 :: Eq a => Eq b => Eq c => (a -> b -> c -> d) -> a -> b -> c -> d -memo4 :: Eq a => Eq b => Eq c => Eq d => (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e -memo5 :: Eq a => Eq b => Eq c => Eq d => Eq e => (a -> b -> c -> d -> e -> f) -> a -> b -> c -> d -> e -> f -memo6 :: Eq a => Eq b => Eq c => Eq d => Eq e => Eq f => (a -> b -> c -> d -> e -> f -> g) -> a -> b -> c -> d -> e -> f -> g -memo7 :: Eq a => Eq b => Eq c => Eq d => Eq e => Eq f => Eq g => (a -> b -> c -> d -> e -> f -> g -> h) -> a -> b -> c -> d -> e -> f -> g -> h -memo8 :: Eq a => Eq b => Eq c => Eq d => Eq e => Eq f => Eq g => Eq h => (a -> b -> c -> d -> e -> f -> g -> h -> i) -> a -> b -> c -> d -> e -> f -> g -> h -> i -memo9 :: Eq a => Eq b => Eq c => Eq d => Eq e => Eq f => Eq g => Eq h => Eq i => (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j +memo1 :: De a => (a -> Html m b) -> a -> Html m b +memo2 :: De a => De b => (a -> b -> Html m c) -> a -> b -> Html m c +memo3 :: De a => De b => De c => (a -> b -> c -> Html m d) -> a -> b -> c -> Html m d +memo4 :: De a => De b => De c => De d => (a -> b -> c -> d -> Html m e) -> a -> b -> c -> d -> Html m e +memo5 :: De a => De b => De c => De d => De e => (a -> b -> c -> d -> e -> Html m f) -> a -> b -> c -> d -> e -> Html m f +memo6 :: De a => De b => De c => De d => De e => De f => (a -> b -> c -> d -> e -> f -> Html m g) -> a -> b -> c -> d -> e -> f -> Html m g +memo7 :: De a => De b => De c => De d => De e => De f => De g => (a -> b -> c -> d -> e -> f -> g -> Html m h) -> a -> b -> c -> d -> e -> f -> g -> Html m h +memo8 :: De a => De b => De c => De d => De e => De f => De g => De h => (a -> b -> c -> d -> e -> f -> g -> h -> Html m i) -> a -> b -> c -> d -> e -> f -> g -> h -> Html m i +memo9 :: De a => De b => De c => De d => De e => De f => De g => De h => De i => (a -> b -> c -> d -> e -> f -> g -> h -> i -> Html m j) -> a -> b -> c -> d -> e -> f -> g -> h -> i -> Html m j memo1 = memo1' (/=) memo2 = memo2' (/=) @@ -81,8 +88,8 @@ uncurry6 f (a,b,c,d,e,g,h) = f a b c d e g h uncurry7 f (a,b,c,d,e,g,h,i) = f a b c d e g h i uncurry8 f (a,b,c,d,e,g,h,i,j) = f a b c d e g h i j -applyEq :: (a -> a -> Bool) -> (a -> b) -> IORef (a, b) -> a -> b -applyEq e f r a = unsafePerformIO $ do +applyDe :: (a -> a -> Bool) -> (a -> b) -> IORef (a, b) -> a -> b +applyDe e f r a = unsafePerformIO $ do (a', b) <- readIORef r if not $ e a' a then return b else do let b' = f a -- GitLab From e04f8633c913ae4f8bc1b8538adc997ddfab9742 Mon Sep 17 00:00:00 2001 From: Isaac Shapira Date: Sat, 27 Feb 2021 15:33:41 -0700 Subject: [PATCH 3/7] depending --- .../pardiff/Shpadoinkle/Backend/ParDiff.hs | 65 +++++++------------ backends/pardiff/package.yaml | 1 + examples/TODOMVC.hs | 9 ++- 3 files changed, 30 insertions(+), 45 deletions(-) diff --git a/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs b/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs index 9f625333..b27bbec9 100644 --- a/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs +++ b/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs @@ -11,6 +11,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -45,7 +46,6 @@ module Shpadoinkle.Backend.ParDiff import Control.Applicative (Alternative) -import Control.Compactable (traverseMaybe) import Control.Monad (forM_, void, when) import Control.Monad.Base (MonadBase (..), liftBaseDefault) import Control.Monad.Catch (MonadCatch, MonadThrow) @@ -189,12 +189,12 @@ setListener i m o k = do unsafeSetProp ("on" <> k) f o -getRaw :: ParVNode a -> Maybe (Once JSM RawNode) +getRaw :: ParVNode a -> Once JSM RawNode getRaw = \case - ParNode mk _ _ _ -> Just mk - ParPotato mk -> Just mk - ParTextNode mk _ -> Just mk - ParDepend _ _ -> Nothing + ParNode mk _ _ _ -> mk + ParPotato mk -> mk + ParTextNode mk _ -> mk + ParDepend _ h -> getRaw h makeProp :: Monad m => (m ~> JSM) -> TVar a -> Prop (ParDiffT a m) a -> ParVProp a @@ -300,20 +300,15 @@ patchChildren => NFData a => RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT a m [ParVNode a] patchChildren (RawNode p) [] new = liftJSM $ do - forM_ new $ \newChild -> - case getRaw newChild of - Nothing -> pure () - Just ronce -> do - RawNode cRaw <- runOnce ronce - _ <- p # "appendChild" $ cRaw - pure () + forM_ new $ \newChild -> do + RawNode cRaw <- runOnce $ getRaw newChild + _ <- p # "appendChild" $ cRaw + pure () pure new patchChildren _ old [] = liftJSM $ do doc <- jsg "document" tmp <- doc # "createElement" $ "div" - old' :: [JSVal] <- traverseMaybe (\x -> case getRaw x of - Just once -> Just . unRawNode <$> runOnce once - Nothing -> pure Nothing) old + old' :: [JSVal] <- traverse (fmap unRawNode . runOnce . getRaw) old void (tmp # "replaceChildren" $ old') void (tmp # "remove" $ ()) pure [] @@ -356,7 +351,8 @@ patch' parent old new = do return $ ParNode raw name ps' cs'' (ParDepend dep html, ParDepend dep' _) - | dep == dep' -> pure $ ParDepend dep html + | dep == dep' -> do + pure $ ParDepend dep html (ParDepend _ html, ParDepend _ html') -> patch' parent html html' @@ -364,13 +360,10 @@ patch' parent old new = do -- node definitely has changed _ -> liftJSM $ do let RawNode p = parent - case (,) <$> getRaw old <*> getRaw new of - Nothing -> return new - Just (mold, mnew) -> do - RawNode r <- runOnce mold - RawNode c <- runOnce mnew - _ <- p # "replaceChild" $ (c, r) - return new + RawNode r <- runOnce $ getRaw old + RawNode c <- runOnce $ getRaw new + _ <- p # "replaceChild" $ (c, r) + return new interpret' @@ -388,12 +381,9 @@ interpret' toJSM (Html h') = h' mkNode mkDep mkPotato mkText doc <- jsg "document" raw' <- doc # "createElement" $ name props toJSM i ps (RawNode raw') - forM_ cs' $ \c -> case getRaw c of - Nothing -> pure () - Just monce -> do - RawNode cRaw <- runOnce monce - _ <- raw' # "appendChild" $ cRaw - pure () + forM_ cs' $ \c -> do + RawNode cRaw <- runOnce $ getRaw c + raw' # "appendChild" $ cRaw return (RawNode raw') let p = Props (makeProp toJSM i <$> getProps ps) @@ -424,16 +414,11 @@ instance setup = setup' patch parent mOld new = case mOld of -- first patch - Nothing -> - liftJSM $ do - let RawNode p = parent - case getRaw new of - Nothing -> pure () - Just monce -> do - RawNode c <- runOnce monce - _ <- p # "appendChild" $ c - pure () - return new + Nothing -> liftJSM $ do + let RawNode p = parent + RawNode c <- runOnce $ getRaw new + _ <- p # "appendChild" $ c + return new Just old -> patch' parent old new diff --git a/backends/pardiff/package.yaml b/backends/pardiff/package.yaml index 9a9ccd74..14fd3fe9 100644 --- a/backends/pardiff/package.yaml +++ b/backends/pardiff/package.yaml @@ -52,6 +52,7 @@ library: - transformers-base >= 0.4.5 && < 0.5 - Shpadoinkle + - Shpadoinkle-console git: https://gitlab.com/fresheyeball/Shpadoinkle.git diff --git a/examples/TODOMVC.hs b/examples/TODOMVC.hs index 2b0cdf5e..46267bf5 100644 --- a/examples/TODOMVC.hs +++ b/examples/TODOMVC.hs @@ -18,8 +18,8 @@ import Data.Text hiding (count, filter, length) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Prelude hiding (div, unwords) -import Shpadoinkle (Html, JSM, NFData, readTVarIO, - shpadoinkle, text) +import Shpadoinkle (Html, JSM, NFData, depending, + readTVarIO, shpadoinkle, text) import Shpadoinkle.Backend.ParDiff (runParDiff, stage) import Shpadoinkle.Html (a, addStyle, autofocus, button, button', checked, class', div, @@ -31,7 +31,6 @@ import Shpadoinkle.Html (a, addStyle, autofocus, button, placeholder, section, span, strong_, type', ul, value) import Shpadoinkle.Html.LocalStorage (manageLocalStorage) -import Shpadoinkle.Html.Memo (memo) import Shpadoinkle.Lens (generalize) import Shpadoinkle.Run (runJSorWarp) @@ -120,7 +119,7 @@ toVisible v = case v of filterHtml :: Applicative m => Visibility -> Visibility -> Html m Visibility -filterHtml = memo $ \cur item -> li_ +filterHtml = curry . depending $ \(cur, item) -> li_ [ a (href "#" : onClick (const item) : [class' ("selected", cur == item)]) [ text . pack $ show item ] ] @@ -131,7 +130,7 @@ htmlIfTasks m h' = if Prelude.null (tasks m) then [] else h' taskView :: Applicative m => Maybe TaskId -> Task -> Html m Model -taskView = memo $ \currentEdit (Task (Description d) c tid) -> +taskView = curry . depending $ \(currentEdit, (Task (Description d) c tid)) -> li [ id' . pack . show $ unTaskId tid , class' [ ("completed", c == Complete) , ("editing", Just tid == currentEdit) -- GitLab From 74e1c4588c68fe26d4f812f5b13cca607e2bea3b Mon Sep 17 00:00:00 2001 From: Isaac Shapira Date: Sat, 27 Feb 2021 15:35:10 -0700 Subject: [PATCH 4/7] lint --- backends/pardiff/Shpadoinkle/Backend/ParDiff.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs b/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs index b27bbec9..6648f2ad 100644 --- a/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs +++ b/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs @@ -11,7 +11,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- GitLab From fe86490dce3540fee8d6b6af36228c134c64e37f Mon Sep 17 00:00:00 2001 From: Isaac Shapira Date: Sat, 27 Feb 2021 15:41:31 -0700 Subject: [PATCH 5/7] lint --- examples/TODOMVC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/TODOMVC.hs b/examples/TODOMVC.hs index 46267bf5..1b6b808a 100644 --- a/examples/TODOMVC.hs +++ b/examples/TODOMVC.hs @@ -130,7 +130,7 @@ htmlIfTasks m h' = if Prelude.null (tasks m) then [] else h' taskView :: Applicative m => Maybe TaskId -> Task -> Html m Model -taskView = curry . depending $ \(currentEdit, (Task (Description d) c tid)) -> +taskView = curry . depending $ \(currentEdit, Task (Description d) c tid) -> li [ id' . pack . show $ unTaskId tid , class' [ ("completed", c == Complete) , ("editing", Just tid == currentEdit) -- GitLab From 18f64142af645e5cd94f650f64dee301df715816 Mon Sep 17 00:00:00 2001 From: Isaac Shapira Date: Sat, 27 Feb 2021 15:55:48 -0700 Subject: [PATCH 6/7] typo fix --- html/Shpadoinkle/Html/Memo.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/html/Shpadoinkle/Html/Memo.hs b/html/Shpadoinkle/Html/Memo.hs index d72b2788..9e069954 100644 --- a/html/Shpadoinkle/Html/Memo.hs +++ b/html/Shpadoinkle/Html/Memo.hs @@ -17,7 +17,7 @@ module Shpadoinkle.Html.Memo ( Memo (..) -- * Uniadic , memo1, memo2, memo3, memo4, memo5, memo6, memo7, memo8, memo9 - -- * Custom Deuality + -- * Custom Equality , memo1', memo2', memo3', memo4', memo5', memo6', memo7', memo8', memo9' ) where @@ -50,7 +50,7 @@ instance {-# OVERLAPS #-} (De a, De b, De c, De d, De e, De f, De g, De h, De i) memo1' e f a = unsafePerformIO $ do r <- newIORef (a, depending f a) - return $ applyDe e f r a + return $ applyEq e f r a memo2' e f a b = memo1' e (uncurry f) (a,b) memo3' e f a b c = memo1' e (uncurry2 f) (a,b,c) memo4' e f a b c d = memo1' e (uncurry3 f) (a,b,c,d) @@ -88,8 +88,8 @@ uncurry6 f (a,b,c,d,e,g,h) = f a b c d e g h uncurry7 f (a,b,c,d,e,g,h,i) = f a b c d e g h i uncurry8 f (a,b,c,d,e,g,h,i,j) = f a b c d e g h i j -applyDe :: (a -> a -> Bool) -> (a -> b) -> IORef (a, b) -> a -> b -applyDe e f r a = unsafePerformIO $ do +applyEq :: (a -> a -> Bool) -> (a -> b) -> IORef (a, b) -> a -> b +applyEq e f r a = unsafePerformIO $ do (a', b) <- readIORef r if not $ e a' a then return b else do let b' = f a -- GitLab From 784e52d68b064cc28fb3a2622b2aefc7e93bc3d4 Mon Sep 17 00:00:00 2001 From: Isaac Shapira Date: Sat, 27 Feb 2021 17:02:10 -0700 Subject: [PATCH 7/7] fix memo --- .../pardiff/Shpadoinkle/Backend/ParDiff.hs | 3 +- core/Shpadoinkle/Core.hs | 18 ++++++++ examples/TODOMVC.hs | 9 ++-- html/Shpadoinkle/Html/Memo.hs | 45 +++++++++---------- 4 files changed, 46 insertions(+), 29 deletions(-) diff --git a/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs b/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs index 6648f2ad..abf36c48 100644 --- a/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs +++ b/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs @@ -350,8 +350,7 @@ patch' parent old new = do return $ ParNode raw name ps' cs'' (ParDepend dep html, ParDepend dep' _) - | dep == dep' -> do - pure $ ParDepend dep html + | dep == dep' -> pure $ ParDepend dep html (ParDepend _ html, ParDepend _ html') -> patch' parent html html' diff --git a/core/Shpadoinkle/Core.hs b/core/Shpadoinkle/Core.hs index 19916397..d6b8abd5 100644 --- a/core/Shpadoinkle/Core.hs +++ b/core/Shpadoinkle/Core.hs @@ -97,6 +97,14 @@ newtype Html m a = Html } +instance Show (Html m a) where + show (Html h') = h' + (\t ps cs -> "Node " ++ show t ++ " " ++ show ps ++ " " ++ show cs) + (\d r -> "Depend (" ++ show d ++ ") (" ++ r ++ ")") + (const "Potato _") + show + + -- | Properties of a DOM node. Backend does not use attributes directly, -- but rather is focused on the more capable properties that may be set on a DOM -- node in JavaScript. If you wish to add attributes, you may do so @@ -123,6 +131,15 @@ data Prop :: (Type -> Type) -> Type -> Type where PListener :: (RawNode -> RawEvent -> JSM (Continuation m a)) -> Prop m a +instance Show (Prop m a) where + show = \case + PData _ -> "PData _" + PText t -> "PText " ++ show t + PFlag b -> "PFlag " ++ show b + PPotato _ -> "PPotato _" + PListener _ -> "PListener _" + + instance Eq (Prop m a) where x == y = case (x,y) of (PText x', PText y') -> x' == y' @@ -141,6 +158,7 @@ listenM_ k = listenC k . causes newtype Props m a = Props { getProps :: Map Text (Prop m a) } + deriving Show toProps :: Applicative m => [(Text, Prop m a)] -> Props m a diff --git a/examples/TODOMVC.hs b/examples/TODOMVC.hs index 1b6b808a..2b0cdf5e 100644 --- a/examples/TODOMVC.hs +++ b/examples/TODOMVC.hs @@ -18,8 +18,8 @@ import Data.Text hiding (count, filter, length) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Prelude hiding (div, unwords) -import Shpadoinkle (Html, JSM, NFData, depending, - readTVarIO, shpadoinkle, text) +import Shpadoinkle (Html, JSM, NFData, readTVarIO, + shpadoinkle, text) import Shpadoinkle.Backend.ParDiff (runParDiff, stage) import Shpadoinkle.Html (a, addStyle, autofocus, button, button', checked, class', div, @@ -31,6 +31,7 @@ import Shpadoinkle.Html (a, addStyle, autofocus, button, placeholder, section, span, strong_, type', ul, value) import Shpadoinkle.Html.LocalStorage (manageLocalStorage) +import Shpadoinkle.Html.Memo (memo) import Shpadoinkle.Lens (generalize) import Shpadoinkle.Run (runJSorWarp) @@ -119,7 +120,7 @@ toVisible v = case v of filterHtml :: Applicative m => Visibility -> Visibility -> Html m Visibility -filterHtml = curry . depending $ \(cur, item) -> li_ +filterHtml = memo $ \cur item -> li_ [ a (href "#" : onClick (const item) : [class' ("selected", cur == item)]) [ text . pack $ show item ] ] @@ -130,7 +131,7 @@ htmlIfTasks m h' = if Prelude.null (tasks m) then [] else h' taskView :: Applicative m => Maybe TaskId -> Task -> Html m Model -taskView = curry . depending $ \(currentEdit, Task (Description d) c tid) -> +taskView = memo $ \currentEdit (Task (Description d) c tid) -> li [ id' . pack . show $ unTaskId tid , class' [ ("completed", c == Complete) , ("editing", Just tid == currentEdit) diff --git a/html/Shpadoinkle/Html/Memo.hs b/html/Shpadoinkle/Html/Memo.hs index 9e069954..8a6c8c02 100644 --- a/html/Shpadoinkle/Html/Memo.hs +++ b/html/Shpadoinkle/Html/Memo.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} @@ -22,10 +23,10 @@ module Shpadoinkle.Html.Memo ( ) where -import Data.IORef -import Data.Typeable +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Typeable (Typeable) import Shpadoinkle (Html, depending) -import System.IO.Unsafe +import System.IO.Unsafe (unsafePerformIO) @@ -48,9 +49,10 @@ instance {-# OVERLAPS #-} (De a, De b, De c, De d, De e, De f, De g) instance {-# OVERLAPS #-} (De a, De b, De c, De d, De e, De f, De g, De h) => Memo (a -> b -> c -> d -> e -> f -> g -> h -> Html m i) where memo = memo8 instance {-# OVERLAPS #-} (De a, De b, De c, De d, De e, De f, De g, De h, De i) => Memo (a -> b -> c -> d -> e -> f -> g -> h -> i -> Html m j) where memo = memo9 -memo1' e f a = unsafePerformIO $ do - r <- newIORef (a, depending f a) - return $ applyEq e f r a +memo1' e f = unsafePerformIO $ do + r <- newIORef Nothing + return $ applyEq e f r +{-# NOINLINE memo1' #-} memo2' e f a b = memo1' e (uncurry f) (a,b) memo3' e f a b c = memo1' e (uncurry2 f) (a,b,c) memo4' e f a b c d = memo1' e (uncurry3 f) (a,b,c,d) @@ -70,15 +72,15 @@ memo7 :: De a => De b => De c => De d => De e => De f => De g => memo8 :: De a => De b => De c => De d => De e => De f => De g => De h => (a -> b -> c -> d -> e -> f -> g -> h -> Html m i) -> a -> b -> c -> d -> e -> f -> g -> h -> Html m i memo9 :: De a => De b => De c => De d => De e => De f => De g => De h => De i => (a -> b -> c -> d -> e -> f -> g -> h -> i -> Html m j) -> a -> b -> c -> d -> e -> f -> g -> h -> i -> Html m j -memo1 = memo1' (/=) -memo2 = memo2' (/=) -memo3 = memo3' (/=) -memo4 = memo4' (/=) -memo5 = memo5' (/=) -memo6 = memo6' (/=) -memo7 = memo7' (/=) -memo8 = memo8' (/=) -memo9 = memo9' (/=) +memo1 = memo1' (==) +memo2 = memo2' (==) +memo3 = memo3' (==) +memo4 = memo4' (==) +memo5 = memo5' (==) +memo6 = memo6' (==) +memo7 = memo7' (==) +memo8 = memo8' (==) +memo9 = memo9' (==) uncurry2 f (a,b,c) = f a b c uncurry3 f (a,b,c,d) = f a b c d @@ -88,11 +90,8 @@ uncurry6 f (a,b,c,d,e,g,h) = f a b c d e g h uncurry7 f (a,b,c,d,e,g,h,i) = f a b c d e g h i uncurry8 f (a,b,c,d,e,g,h,i,j) = f a b c d e g h i j -applyEq :: (a -> a -> Bool) -> (a -> b) -> IORef (a, b) -> a -> b -applyEq e f r a = unsafePerformIO $ do - (a', b) <- readIORef r - if not $ e a' a then return b else do - let b' = f a - writeIORef r (a', b') - return b' - +applyEq :: (Typeable a, Eq a, Show a) => (a -> a -> Bool) -> (a -> Html m b) -> IORef (Maybe (a, Html m b)) -> a -> Html m b +applyEq e f r a = unsafePerformIO $ readIORef r >>= \case + Just (a', b) | e a' a -> return b + _ -> let b = depending f a in b <$ writeIORef r (Just (a, b)) +{-# NOINLINE applyEq #-} -- GitLab