Verified Commit 784e52d6 authored by Isaac Shapira's avatar Isaac Shapira
Browse files

fix memo

parent 18f64142
Pipeline #262901713 passed with stages
in 15 minutes and 46 seconds
......@@ -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'
......
......@@ -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
......
......@@ -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)
......
{-# 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 #-}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment