git.iko.soy/reflex
on develop help sign in
Add basic NubDynamic implementation
73613bdRyan Trinkle
src/Reflex.hs+2
compare with develop
unifiedsplit
@@ -1,10 +1,12 @@
1module Reflex ( module Reflex.Class
1module Reflex ( module Reflex.Class
2 , module Reflex.Dynamic
2 , module Reflex.Dynamic
3+ , module Reflex.Dynamic.Nub
3 , module Reflex.Dynamic.TH
4 , module Reflex.Dynamic.TH
4 , module Reflex.Spider
5 , module Reflex.Spider
5 ) where
6 ) where
6
7
7import Reflex.Class
8import Reflex.Class
8import Reflex.Dynamic
9import Reflex.Dynamic
10+import Reflex.Dynamic.Nub
9import Reflex.Dynamic.TH
11import Reflex.Dynamic.TH
10import Reflex.Spider
12import Reflex.Spider
src/Reflex/Dynamic.hs+4−4
@@ -101,7 +101,7 @@ nubDyn d =
101instance Reflex t => Functor (Dynamic t) where
101instance Reflex t => Functor (Dynamic t) where
102 fmap f d =
102 fmap f d =
103 let e' = fmap f $ updated d
103 let e' = fmap f $ updated d
104− eb' = push (\b' -> liftM Just $ constant b') e'
104+ eb' = push (\b' -> fmap Just $ constant b') e'
105 b0 = fmap f $ current d
105 b0 = fmap f $ current d
106
106
107-}
107-}
@@ -124,7 +124,7 @@ foldDyn f = foldDynMaybe $ \o v -> Just $ f o v
124-- time the 'Event' occurs using a monadic folding function on the
124-- time the 'Event' occurs using a monadic folding function on the
125-- previous value and the value of the 'Event'.
125-- previous value and the value of the 'Event'.
126foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
126foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
127−foldDynM f = foldDynMaybeM $ \o v -> liftM Just $ f o v
127+foldDynM f = foldDynMaybeM $ \o v -> fmap Just $ f o v
128
128
129foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
129foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
130foldDynMaybe f = foldDynMaybeM $ \o v -> return $ f o v
130foldDynMaybe f = foldDynMaybeM $ \o v -> return $ f o v
@@ -167,7 +167,7 @@ firstE (h:t) = mergeEventsLeftBiased h =<< firstE t
167concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a)
167concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a)
168concatEventsWith _ [] = return never
168concatEventsWith _ [] = return never
169concatEventsWith _ [e] = return e
169concatEventsWith _ [e] = return e
170−concatEventsWith f es = mapEM (liftM (foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) . sequenceDmap) <=< mergeEventDMap $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
170+concatEventsWith f es = mapEM (fmap (foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) . sequenceDmap) <=< mergeEventDMap $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
171--concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t
171--concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t
172
172
173mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)
173mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)
@@ -320,7 +320,7 @@ getDemuxed d k = return $ demuxed d k
320demuxed :: (Reflex t, Eq k) => Demux t k -> k -> Dynamic t Bool
320demuxed :: (Reflex t, Eq k) => Demux t k -> k -> Dynamic t Bool
321demuxed d k =
321demuxed d k =
322 let e = select (demuxSelector d) (Const2 k)
322 let e = select (demuxSelector d) (Const2 k)
323− in unsafeBuildDynamic (liftM (==k) $ sample $ demuxValue d) e
323+ in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e
324
324
325--------------------------------------------------------------------------------
325--------------------------------------------------------------------------------
326-- collectDyn
326-- collectDyn
src/Reflex/Dynamic/Nub.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# LANGUAGE MagicHash #-}
2+module Reflex.Dynamic.Nub
3+ ( NubDynamic
4+ , nubDynamic
5+ , fromNubDynamic
6+ , foldNubDyn
7+ , foldNubDynM
8+ , foldNubDynMaybe
9+ , foldNubDynMaybeM
10+ ) where
11+
12+import Reflex.Class
13+import Reflex.Dynamic
14+
15+import Control.Monad.Fix
16+import GHC.Exts
17+
18+newtype NubDynamic t a = NubDynamic { unNubDynamic :: Dynamic t a }
19+
20+nubDynamic :: Reflex t => Dynamic t a -> NubDynamic t a
21+nubDynamic d = NubDynamic $ unsafeBuildDynamic (sample $ current d) $ flip push (updated d) $ \new -> do --TODO: It would be very nice if we had an uncached push here
22+ old <- sample $ current d --TODO: Is it better to sample ourselves here?
23+ return $ unsafeJustChanged old new
24+
25+fromNubDynamic :: (Reflex t, Eq a) => NubDynamic t a -> Dynamic t a
26+fromNubDynamic (NubDynamic d) = nubDyn d
27+
28+unsafeJustChanged :: a -> a -> Maybe a
29+unsafeJustChanged old new = case old `seq` new `seq` reallyUnsafePtrEquality# old new of
30+ 0# -> Just new
31+ _ -> Nothing
32+
33+foldNubDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (NubDynamic t b)
34+foldNubDyn f = foldNubDynMaybe $ \o v -> Just $ f o v
35+
36+foldNubDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (NubDynamic t b)
37+foldNubDynM f = foldNubDynMaybeM $ \o v -> fmap Just $ f o v
38+
39+foldNubDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (NubDynamic t b)
40+foldNubDynMaybe f = foldNubDynMaybeM $ \o v -> return $ f o v
41+
42+foldNubDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (NubDynamic t b)
43+foldNubDynMaybeM f z e = do
44+ let f' change old = do
45+ x <- f change old
46+ return $ case x of
47+ Nothing -> Nothing
48+ Just new -> unsafeJustChanged old new
49+ d <- foldDynMaybeM f' z e
50+ return $ NubDynamic d
51+
52+instance Reflex t => Functor (NubDynamic t) where
53+ fmap f (NubDynamic d) = nubDynamic $ fmap f d
54+
55+instance Reflex t => Applicative (NubDynamic t) where
56+ pure = NubDynamic . constDyn
57+ NubDynamic a <*> NubDynamic b = nubDynamic $ a <*> b
58+ _ *> b = b
59+ a <* _ = a
60+
61+instance Reflex t => Monad (NubDynamic t) where
62+ NubDynamic x >>= f = nubDynamic $ x >>= unNubDynamic . f
63+ _ >> b = b
64+ return = pure