fix memo

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'

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

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)

html/Shpadoinkle/Html/Memo.hs

 {-# 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 #-}