packages feed

reflex 0.1.1 → 0.2

raw patch · 8 files changed

+367/−116 lines, 8 filesdep +criteriondep +deepseqdep +ref-tfdep ~basedep ~dependent-mapdep ~dependent-sum

Dependencies added: criterion, deepseq, ref-tf, reflex, stm, transformers

Dependency ranges changed: base, dependent-map, dependent-sum, mtl, primitive

Files

+ bench/Main.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Main where++import Data.Functor.Misc+import Control.Monad.Primitive+import Control.Monad.IO.Class+import Data.Dependent.Sum+import Control.Concurrent.STM+import Control.Applicative+import System.IO.Unsafe+import Data.IORef+import Control.DeepSeq+import Control.Exception (evaluate)+import Control.Monad+import Reflex+import Reflex.Host.Class+import System.Mem+import System.IO+import Criterion.Main++import qualified Data.Traversable as T++import qualified Data.Dependent.Map as DM+++main :: IO ()+main = defaultMain+  [ bgroup "micro" micros ]++instance NFData (IORef a) where+  rnf x = seq x ()++instance NFData (TVar a) where+  rnf x = seq x ()++newtype WHNF a = WHNF a+instance NFData (WHNF a) where+  rnf (WHNF a) = seq a ()++withSetup :: NFData b => String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark+withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->+  bench name . nfIO $ runSpiderHost (action a)++withSetupWHNF :: String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark+withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->+  bench name . whnfIO $ runSpiderHost (action a)+++micros :: [Benchmark]+micros =+  [ bench "newIORef" $ whnfIO $ void $ newIORef ()+  , env (newIORef (42 :: Int)) (bench "readIORef" . whnfIO . readIORef)+  , bench "newTVar" $ whnfIO $ void $ newTVarIO ()+  , env (newTVarIO (42 :: Int)) (bench "readTVar" . whnfIO . readTVarIO)+  , bench "newEventWithTrigger" $ whnfIO . void $ runSpiderHost $ newEventWithTrigger $+      \trigger -> return () <$ evaluate trigger+  , bench "newEventWithTriggerRef" $ whnfIO . void $ runSpiderHost newEventWithTriggerRef+  , withSetupWHNF "subscribeEvent" newEventWithTriggerRef $ subscribeEvent . fst+  , withSetupWHNF "subscribeSwitch"+    (join $ hold <$> fmap fst newEventWithTriggerRef <*> fmap fst newEventWithTriggerRef)+    (subscribeEvent . switch)+  , withSetupWHNF "subscribeMerge(1)" (setupMerge 1) $ \(ev,_) -> subscribeEvent ev+  , withSetupWHNF "subscribeMerge(100)" (setupMerge 100) (subscribeEvent . fst)+  , withSetupWHNF "subscribeMerge(10000)" (setupMerge 10000) (subscribeEvent . fst)+  , bench "runHostFrame" $ whnfIO $ runSpiderHost $ runHostFrame $ return ()+  , withSetupWHNF "fireEventsAndRead(single/single)"+    (newEventWithTriggerRef >>= subscribePair)+    (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd)+  , withSetupWHNF "fireEventsOnly"+    (newEventWithTriggerRef >>= subscribePair)+    (\(subd, trigger) -> do+        Just key <- liftIO $ readIORef trigger+        fireEvents [key :=> (42 :: Int)])+  , withSetupWHNF "fireEventsAndRead(head/merge1)"+    (setupMerge 1 >>= subscribePair)+    (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)+  , withSetupWHNF "fireEventsAndRead(head/merge100)"+    (setupMerge 100 >>= subscribePair)+    (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)+  , withSetupWHNF "fireEventsAndRead(head/merge10000)"+      (setupMerge 10000 >>= subscribePair)+      (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)+  , withSetupWHNF "fireEventsOnly(head/merge100)"+    (setupMerge 100 >>= subscribePair)+    (\(subd, t:riggers) -> do+        Just key <- liftIO $ readIORef t+        fireEvents [key :=> (42 :: Int)])+  , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev,trigger) -> hold (42 :: Int) ev+  , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample    +  ]++setupMerge :: Int+           -> SpiderHost (Event Spider (DM.DMap (Const2 Int a)),+                         [IORef (Maybe (EventTrigger Spider a))])+setupMerge num = do+  (evs, triggers) <- unzip <$> replicateM 100 newEventWithTriggerRef+  let !m = DM.fromList [WrapArg (Const2 i) :=> v | (i,v) <- zip [0..] evs]+  pure (merge m, triggers)++subscribePair :: (Event Spider a, b) -> SpiderHost (EventHandle Spider a, b)+subscribePair (ev, b) = (,b) <$> subscribeEvent ev++fireAndRead :: IORef (Maybe (EventTrigger Spider a)) -> a -> EventHandle Spider b+            -> SpiderHost (Maybe b)+fireAndRead trigger val subd = do+  Just key <- liftIO $ readIORef trigger+  fireEventsAndRead [key :=> val] $ readEvent subd >>= T.sequence
reflex.cabal view
@@ -1,5 +1,5 @@ Name: reflex-Version: 0.1.1+Version: 0.2 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3@@ -20,11 +20,12 @@     dependent-sum == 0.2.*,     dependent-map == 0.1.*,     semigroups == 0.16.*,-    mtl == 2.2.*,+    mtl >= 2.1 && < 2.3,     containers == 0.5.*,     these == 0.4.*,     primitive == 0.5.*,-    template-haskell >= 2.9 && < 2.11+    template-haskell >= 2.9 && < 2.11,+    ref-tf == 0.4.*    exposed-modules:     Reflex,@@ -34,12 +35,28 @@     Reflex.Dynamic,     Reflex.Dynamic.TH,     Reflex.Host.Class,-    Data.Functor.Misc,-    Control.Monad.Ref+    Data.Functor.Misc    other-extensions: TemplateHaskell   ghc-prof-options: -fprof-auto   ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2++benchmark spider-bench+  type: exitcode-stdio-1.0+  hs-source-dirs: bench+  main-is: Main.hs+  ghc-options: -O2 -rtsopts+  build-depends:+    base,+    dependent-sum,+    dependent-map,+    transformers >= 0.3 && < 0.5,+    stm == 2.4.*,+    deepseq >= 1.3 && < 1.5,+    mtl,+    primitive,+    criterion == 1.1.*,+    reflex  source-repository head   type: git
− src/Control/Monad/Ref.hs 
@@ -1,85 +0,0 @@-{-# LANGUAGE RecursiveDo, TypeFamilies, LambdaCase #-}-module Control.Monad.Ref where--import Control.Monad-import Control.Monad.Trans-import Control.Monad.Reader-import Control.Monad.Writer-import Data.IORef--class Monad m => MonadRef m where-  type Ref m :: * -> *-  newRef :: a -> m (Ref m a)-  readRef :: Ref m a -> m a-  writeRef :: Ref m a -> a -> m ()-  atomicModifyRef :: Ref m a -> (a -> (a, b)) -> m b--instance MonadRef IO where-  type Ref IO = IORef-  {-# INLINE newRef #-}-  newRef = newIORef-  {-# INLINE readRef #-}-  readRef = readIORef-  {-# INLINE writeRef #-}-  writeRef = writeIORef-  {-# INLINE atomicModifyRef #-}-  atomicModifyRef r f = do-    result <- atomicModifyIORef' r f---    evaluate =<< readIORef r --TODO: Verify that ghcjs now strictly evaluates the values in atomicModifyIORef', then remove this line-    return result--{-# INLINE cacheM #-}-cacheM :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a, m ())-cacheM a = do-  r <- newRef undefined-  let invalidate = writeRef r $ do-        result <- a-        writeRef r $ return result-        return result-  invalidate-  return (join $ readRef r, invalidate)--{-# INLINE cacheMWithTry #-}-cacheMWithTry :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a, m (Maybe a), m ())-cacheMWithTry a = do-  r <- newRef $ Left a-  let invalidate = writeRef r $ Left a-      get = readRef r >>= \case-        Left a' -> do-          result <- a'-          writeRef r $ Right result-          return result-        Right result -> return result-      tryGet = readRef r >>= \case-        Left _ -> return Nothing-        Right result -> return $ Just result-  return (get, tryGet, invalidate)---- | Not thread-safe or reentrant-{-# INLINE memoM #-}-memoM :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a)-memoM = liftM fst . cacheM--{-# INLINE replaceRef #-}-replaceRef :: MonadRef m => Ref m a -> a -> m a-replaceRef r new = atomicModifyRef r $ \old -> (new, old)--{-# INLINE modifyRef #-}-modifyRef :: MonadRef m => Ref m a -> (a -> a) -> m ()-modifyRef r f = atomicModifyRef r $ \a -> (f a, ())--instance (Monoid w, MonadRef m) => MonadRef (WriterT w m) where-  {-# SPECIALIZE instance Monoid w => MonadRef (WriterT w IO) #-}-  type Ref (WriterT w m) = Ref m-  newRef = lift . newRef-  readRef = lift . readRef-  writeRef r = lift . writeRef r-  atomicModifyRef r f = lift $ atomicModifyRef r f--instance MonadRef m => MonadRef (ReaderT r m) where-  {-# SPECIALIZE instance MonadRef (ReaderT r IO) #-}-  type Ref (ReaderT r m) = Ref m-  newRef = lift . newRef-  readRef = lift . readRef-  writeRef r = lift . writeRef r-  atomicModifyRef r f = lift $ atomicModifyRef r f
src/Reflex/Class.hs view
@@ -70,9 +70,12 @@ -- Convenience functions -------------------------------------------------------------------------------- +-- | Create an Event from another Event.+-- The provided function can sample 'Behavior's and hold 'Event's. pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b pushAlways f e = push (liftM Just . f) e +-- | Flipped version of 'fmap'. ffor :: Functor f => f a -> (a -> b) -> f b ffor = flip fmap @@ -80,12 +83,17 @@   fmap f = pull . liftM f . sample  --TODO: See if there's a better class in the standard libraries already+-- | A class for values that combines filtering and mapping using 'Maybe'. class FunctorMaybe f where+  -- | Combined mapping and filtering function.   fmapMaybe :: (a -> Maybe b) -> f a -> f b +-- | Flipped version of 'fmapMaybe'. fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b fforMaybe = flip fmapMaybe +-- | Filter 'f a' using the provided predicate.+-- Relies on 'fforMaybe'. ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing @@ -95,6 +103,9 @@ instance Reflex t => Functor (Event t) where   fmap f = fmapMaybe $ Just . f +-- | Create a new 'Event' by combining each occurence with the next value+-- of the list using the supplied function. If the list runs out of items,+-- all subsequent 'Event' occurrences will be ignored. zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c) zipListWithEvent f l e = do   rec lb <- hold l eTail@@ -107,22 +118,33 @@       lb `seq` eBoth `seq` eTail `seq` return ()   return $ fmap fst eBoth --- | Replace the occurrence value of the Event with the value of the Behavior at the time of the occurrence+-- | Replace each occurrence value of the 'Event' with the value of the+-- 'Behavior' at the time of that occurrence. tag :: Reflex t => Behavior t b -> Event t a -> Event t b tag b = pushAlways $ \_ -> sample b -attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c-attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b+-- | Create a new 'Event' that combines occurences of supplied 'Event'+-- with the current value of the 'Behavior'.+attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)+attach = attachWith (,) +-- | Create a new 'Event' that occurs when the supplied 'Event' occurs+-- by combining it with the current value of the 'Behavior'. attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c attachWith f = attachWithMaybe $ \a b -> Just $ f a b -attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)-attach = attachWith (,)+-- | Create a new 'Event' by combining each occurence with the current+-- value of the 'Behavior'. The occurrence is discarded if the combining function+-- returns Nothing+attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c+attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b +-- | Alias for 'headE' onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) onceE = headE +-- | Create a new 'Event' that only occurs on the first occurence of+-- the supplied 'Event'. headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) headE e = do   rec be <- hold e $ fmap (const never) e'@@ -130,24 +152,42 @@       e' `seq` return ()   return e' +-- | Create a new 'Event' that occurs on all but the first occurence+-- of the supplied 'Event'. tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) tailE e = liftM snd $ headTailE e +-- | Create a tuple of two 'Event's with the first one occuring only+-- the first time the supplied 'Event' occurs and the second occuring+-- on all but the first occurence. headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a) headTailE e = do   eHead <- headE e   be <- hold never $ fmap (const e) eHead   return (eHead, switch be) +-- | Split the supplied 'Event' into two individual 'Event's occuring+-- at the same time with the respective values from the tuple. splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b) splitE e = (fmap fst e, fmap snd e) +-- | Print the supplied 'String' and the value of the 'Event' on each+-- occurence. This should /only/ be used for debugging.+--+-- Note: As with Debug.Trace.trace, the message will only be printed if+-- the 'Event' is actually used. traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a traceEvent s = traceEventWith $ \x -> s <> ": " <> show x +-- | Print the output of the supplied function on each occurence of+-- the 'Event'. This should /only/ be used for debugging.+--+-- Note: As with Debug.Trace.trace, the message will only be printed if+-- the 'Event' is actually used. traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a traceEventWith f = push $ \x -> trace (f x) $ return $ Just x +-- | Tag type for 'Either' to use it as a 'DSum'. data EitherTag l r a where   LeftTag :: EitherTag l r l   RightTag :: EitherTag l r r@@ -175,16 +215,19 @@     LeftTag -> showsPrec n a     RightTag -> showsPrec n a +-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'. eitherToDSum :: Either a b -> DSum (EitherTag a b) eitherToDSum = \case   Left a -> LeftTag :=> a   Right b -> RightTag :=> b +-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'. dsumToEither :: DSum (EitherTag a b) -> Either a b dsumToEither = \case   LeftTag :=> a -> Left a   RightTag :=> b -> Right b +-- | Extract the values of a 'DMap' of 'EitherTag's. dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b) dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of   (Nothing, Nothing) -> Nothing@@ -192,9 +235,13 @@   (Nothing, Just b) -> Just $ That b   (Just a, Just b) -> Just $ These a b +-- | Create a new 'Event' that occurs if at least one of the supplied+-- 'Event's occurs. If both occur at the same time they are combined+-- using 'mappend'. appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a appendEvents e1 e2 = fmap (mergeThese mappend) $ align e1 e2 +{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-} sequenceThese :: Monad m => These (m a) (m b) -> m (These a b) sequenceThese t = case t of   This ma -> liftM This ma@@ -206,19 +253,33 @@   mappend a b = mconcat [a, b]   mconcat = fmap sconcat . mergeList +-- | Create a new 'Event' that occurs if at least one of the 'Event's+-- in the list occurs. If multiple occur at the same time they are+-- folded from the left with the given function. mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) $ merge $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es +-- | Create a new 'Event' that occurs if at least one of the 'Event's+-- in the list occurs. If multiple occur at the same time the value is+-- the value of the leftmost event. leftmost :: Reflex t => [Event t a] -> Event t a leftmost = mergeWith const +-- | Create a new 'Event' that occurs if at least one of the 'Event's+-- in the list occurs and has a list of the values of all 'Event's+-- occuring at that time. mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a) mergeList [] = never mergeList es = mergeWith (<>) $ map (fmap (:|[])) es +-- | Create a new 'Event' combining the map of 'Event's into an+-- 'Event' that occurs if at least one of them occurs and has a map of+-- values of all 'Event's occuring at that time. mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a) mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap +-- | Split the event into an 'EventSelector' that allows efficient+-- selection of the individual 'Event's. fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a) fanMap = fan . fmap mapToDMap @@ -234,5 +295,7 @@   nil = never   align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb] +-- | Create a new 'Event' that only occurs if the supplied 'Event'+-- occurs and the 'Behavior' is true at the time of occurence. gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
src/Reflex/Dynamic.hs view
@@ -88,27 +88,36 @@       => HBuild' l (a->r) where   hBuild' l x = hBuild' (HCons x l) -+-- | A container for a value that can change over time and allows notifications on changes.+-- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will+-- change if and only if the Event fires. data Dynamic t a   = Dynamic (Behavior t a) (Event t a)  unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a unsafeDynamic = Dynamic +-- | Extract the 'Behavior' of a 'Dynamic'. current :: Dynamic t a -> Behavior t a current (Dynamic b _) = b +-- | Extract the 'Event' of the 'Dynamic'. updated :: Dynamic t a -> Event t a updated (Dynamic _ e) = e +-- | 'Dynamic' with the constant supplied value. constDyn :: Reflex t => a -> Dynamic t a constDyn x = Dynamic (constant x) never +-- | Create a 'Dynamic' using the initial value that changes every+-- time the 'Event' occurs. holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a) holdDyn v0 e = do   b <- hold v0 e   return $ Dynamic b e +-- | Create a new 'Dynamic' that only signals changes if the values+-- actually changed. nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a nubDyn d =   let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)@@ -123,12 +132,16 @@      -}       +-- | Map a function over a 'Dynamic'. mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b) mapDyn f = mapDynM $ return . f +-- | Flipped version of 'mapDyn'. forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b) forDyn = flip mapDyn +-- | Map a monadic function over a 'Dynamic'.  The only monadic action that the given function can+-- perform is 'sample'. {-# INLINE mapDynM #-} mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b) mapDynM f d = do@@ -139,9 +152,15 @@   let b' = pull $ sample =<< sample bb'   return $ Dynamic b' e' +-- | Create a 'Dynamic' using the initial value and change it each+-- time the 'Event' occurs using a folding function on the previous+-- value and the value of the 'Event'. foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b) foldDyn f = foldDynM (\o v -> return $ f o v) +-- | Create a 'Dynamic' using the initial value and change it each+-- time the 'Event' occurs using a monadic folding function on the+-- previous value and the value of the 'Event'. foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b) foldDynM f z e = do   rec let e' = flip push e $ \o -> do@@ -150,13 +169,18 @@       b' <- hold z e'   return $ Dynamic b' e' +-- | Create a new 'Dynamic' that counts the occurences of the 'Event'. count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b) count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e +-- | Create a new 'Dynamic' using the initial value that flips its+-- value every time the 'Event' occurs. toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool) toggle = foldDyn (const not) --- | Switches to the new event whenever it receives one.  Switching occurs *before* occurring the inner event.+-- | Switches to the new 'Event' whenever it receives one.  Switching+-- occurs *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the old and new+-- inner Events fire simultaneously, the output will fire with the value of the *new* 'Event'. switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a switchPromptlyDyn de =   let eLag = switch $ current de@@ -182,14 +206,19 @@ mconcatE = concatEventsWith mappend -} +-- | Split the 'Dynamic' into two 'Dynamic's, each taking the+-- respective value of the tuple. splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b) splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d) +-- | Merge the 'Dynamic' values using their 'Monoid' instance. mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a) mconcatDyn es = do   ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es   mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm +-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of+-- Dynamic values. distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k)) distributeDMapOverDyn dm = case DMap.toList dm of   [] -> return $ constDyn DMap.empty@@ -208,6 +237,9 @@     let bdm = pull $ sample =<< sample bbdm     return $ Dynamic bdm edm +-- | Merge two 'Dynamic's into a new one using the provided+-- function. The new 'Dynamic' changes its value each time one of the+-- original 'Dynamic's changes its value. combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c) combineDyn f da db = do   let eab = align (updated da) (updated db)@@ -234,6 +266,8 @@   in leftmost [eFast, eSlow] -} +-- | Join a nested 'Dynamic' into a new 'Dynamic' that has the value+-- of the inner 'Dynamic'. joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a joinDyn dd =   let b' = pull $ sample . current =<< sample (current dd)@@ -244,6 +278,8 @@   in Dynamic b' e'  --TODO: Generalize this to functors other than Maps+-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'+-- with the current values of the 'Dynamic's in a map. joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a) joinDynThroughMap dd =   let b' = pull $ mapM (sample . current) =<< sample (current dd)@@ -258,23 +294,57 @@       e' = leftmost [eBoth, eOuter, eInner]   in Dynamic b' e' +-- | Print the value of the 'Dynamic' on each change and prefix it+-- with the provided string. This should /only/ be used for debugging.+--+-- Note: Just like Debug.Trace.trace, the value will only be shown if something+-- else in the system is depending on it. traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a traceDyn s = traceDynWith $ \x -> s <> ": " <> show x +-- | Print the result of applying the provided function to the value+-- of the 'Dynamic' on each change. This should /only/ be used for+-- debugging.+--+-- Note: Just like Debug.Trace.trace, the value will only be shown if something+-- else in the system is depending on it. traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a traceDynWith f d =   let e' = traceEventWith f $ updated d   in Dynamic (current d) e' +-- | Replace the value of the 'Event' with the current value of the 'Dynamic'+-- each time the 'Event' occurs.+--+-- Note: `tagDyn d e` differs from `tag (current d) e` in the case that `e` is firing+-- at the same time that `d` is changing.  With `tagDyn d e`, the *new* value of `d`+-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value+-- will be used, since the 'Behavior' won't be updated until the end of the frame.+-- Additionally, this means that the output 'Event' may not be used to directly change+-- the input 'Dynamic', because that would mean its value depends on itself.  When creating+-- cyclic data flows, generally `tag (current d) e` is preferred. tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a tagDyn = attachDynWith const +-- | Attach the current value of the 'Dynamic' to the value of the+-- 'Event' each time it occurs.+--+-- Note: `attachDyn d` is not the same as `attach (current d)`.  See 'tagDyn' for details. attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b) attachDyn = attachDynWith (,) +-- | Combine the current value of the 'Dynamic' with the value of the+-- 'Event' each time it occurs.+--+-- Note: `attachDynWith f d` is not the same as `attachWith f (current d)`.  See 'tagDyn' for details. attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b +-- | Create a new 'Event' by combining the value at each occurence+-- with the current value of the 'Dynamic' value and possibly+-- filtering if the combining function returns 'Nothing'.+--+-- Note: `attachDynWithMaybe f d` is not the same as `attachWithMaybe f (current d)`.  See 'tagDyn' for details. attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c attachDynWithMaybe f d e =   let e' = attach (current d) e@@ -287,14 +357,25 @@ -- Demux -------------------------------------------------------------------------------- +-- | Represents a time changing value together with an 'EventSelector'+-- that can efficiently detect when the underlying Dynamic has a particular value.+-- This is useful for representing data like the current selection of a long list.+--+-- Semantically,+-- > getDemuxed (demux d) k === mapDyn (== k) d+-- However, the when getDemuxed is used multiple times, the complexity is only /O(log(n))/,+-- rather than /O(n)/ for mapDyn. data Demux t k = Demux { demuxValue :: Behavior t k                        , demuxSelector :: EventSelector t (Const2 k Bool)                        } +-- | Demultiplex an input value to a 'Demux' with many outputs.  At any given time, whichever output is indicated by the given 'Dynamic' will be 'True'. demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k demux k = Demux (current k) (fan $ attachWith (\k0 k1 -> if k0 == k1 then DMap.empty else DMap.fromList [Const2 k0 :=> False, Const2 k1 :=> True]) (current k) (updated k))  --TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out+-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)+-- mapping over the original 'Dynamic' and checking whether it is equal to the given key. getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool) getDemuxed d k = do   let e = select (demuxSelector d) (Const2 k)
src/Reflex/Dynamic/TH.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, GADTs, EmptyDataDecls #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, GADTs, EmptyDataDecls, PatternGuards #-} module Reflex.Dynamic.TH (qDyn, unqDyn) where  import Reflex.Dynamic
src/Reflex/Host/Class.hs view
@@ -19,6 +19,13 @@   readEvent :: EventHandle t a -> m (Maybe (m a))  class (Monad m, ReflexHost t) => MonadReflexCreateTrigger t m | m -> t where+  -- | Creates an original Event (one that is not based on any other event).+  -- When a subscriber first subscribes to an event (building another event+  -- that depends on the subscription) the given callback function is run by+  -- passing a trigger. The event is then set up in IO. The callback+  -- function returns an accompanying teardown action.+  -- Any time between setup and teardown the trigger can be used to fire+  -- the event.   newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)  class (Monad m, ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexHost t m | m -> t where
src/Reflex/Spider/Internal.hs view
@@ -13,7 +13,9 @@ import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence) import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence) import GHC.Exts+#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#endif import Data.Dependent.Map (DMap, DSum (..)) import qualified Data.Dependent.Map as DMap import Data.GADT.Compare@@ -164,7 +166,7 @@           , holdNodeId = unsafeNodeId (v0, e) #endif           }-        !s = SubscriberHold h+    s <- newSubscriberHold h     writeIORef subscriberRef $ unsafeCoerce s     modifyIORef' holdInitRef (SomeHoldInit e h :)     return $ BehaviorHold h@@ -277,7 +279,7 @@ data FanSubscribed k    = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))                    , fanSubscribedParent :: !(EventSubscribed (DMap k))-                   , fanSubscribedSelf :: !(Subscriber (DMap k))+                   , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k)) #ifdef DEBUG_NODEIDS                    , fanSubscribedNodeId :: Int #endif@@ -292,9 +294,9 @@    = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))                       , switchSubscribedHeight :: !(IORef Int)                       , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])-                      , switchSubscribedSelf :: !(Subscriber a)+                      , switchSubscribedSelf :: {-# NOUNPACK #-} (Subscriber a)                       , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))-                      , switchSubscribedOwnInvalidator :: !Invalidator+                      , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} Invalidator                       , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))                       , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])                       , switchSubscribedParent :: !(Behavior (Event a))@@ -313,7 +315,7 @@    = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))                            , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])                            , coincidenceSubscribedHeight :: !(IORef Int)-                           , coincidenceSubscribedOuter :: !(Subscriber (Event a))+                           , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))                            , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))                            , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a))) #ifdef DEBUG_NODEIDS@@ -390,6 +392,59 @@    | EventSubscribedSwitch !(SwitchSubscribed a)    | EventSubscribedCoincidence !(CoincidenceSubscribed a) +-- These function are constructor functions that are marked NOINLINE so they are+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away+-- so any weak references that are attached to the constructors will have their+-- finalizer run. Using the opaque constructor, does not see the+-- constructor application, so it behaves like an IORef and cannot be fused away.+--+-- The result is also evaluated to WHNF, since forcing a thunk invalidates+-- the weak pointer to it in some cases.++{-# NOINLINE newRootSubscribed #-}+newRootSubscribed :: IORef (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)+newRootSubscribed occ subs =+  return $! RootSubscribed+    { rootSubscribedOccurrence = occ+    , rootSubscribedSubscribers = subs+    }++{-# NOINLINE newSubscriberPush #-}+newSubscriberPush :: (a -> EventM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)+newSubscriberPush compute subd = return $! SubscriberPush compute subd++{-# NOINLINE newSubscriberHold #-}+newSubscriberHold :: Hold a -> IO (Subscriber a)+newSubscriberHold h = return $! SubscriberHold h++{-# NOINLINE newSubscriberFan #-}+newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k))+newSubscriberFan subd = return $! SubscriberFan subd++{-# NOINLINE newSubscriberSwitch #-}+newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a)+newSubscriberSwitch subd = return $! SubscriberSwitch subd++{-# NOINLINE newSubscriberCoincidenceOuter #-}+newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b))+newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd++{-# NOINLINE newSubscriberCoincidenceInner #-}+newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a)+newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd++{-# NOINLINE newInvalidatorSwitch #-}+newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd++{-# NOINLINE newInvalidatorPull #-}+newInvalidatorPull :: Pull a -> IO Invalidator+newInvalidatorPull p = return $! InvalidatorPull p++{-# NOINLINE newBox #-}+newBox :: a -> IO (Box a)+newBox a = return $! Box a+ --type role Behavior representational data Behavior a    = BehaviorHold !(Hold a)@@ -605,7 +660,7 @@  subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a) subscribeCoincidenceInner o outerHeight subscribedUnsafe = do-  let !subInner = SubscriberCoincidenceInner subscribedUnsafe+  subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe   wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"   innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)   innerOcc <- liftIO $ getEventSubscribedOcc innerSubd@@ -644,7 +699,7 @@         liftIO $ touch $ pullSubscribedOwnInvalidator subscribed         return $ pullSubscribedValue subscribed       Nothing -> do-        let !i = InvalidatorPull p+        i <- liftIO $ newInvalidatorPull p         wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"         parentsRef <- liftIO $ newIORef []         a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)@@ -776,10 +831,7 @@     Just subscribed -> return subscribed     Nothing -> liftIO $ do       subscribersRef <- newIORef []-      let !subscribed = RootSubscribed-            { rootSubscribedOccurrence = rootOccurrence r-            , rootSubscribedSubscribers = subscribersRef-            }+      subscribed <- newRootSubscribed (rootOccurrence r) subscribersRef       -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory       uninit <- rootInit r $ RootTrigger (subscribersRef, rootOccurrence r)       addFinalizer subscribed $ do@@ -797,7 +849,7 @@     Just subscribed -> return subscribed     Nothing -> do -- Not yet subscribed       subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p-      let !s = SubscriberPush (pushCompute p) subscribedUnsafe+      s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe       ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"       subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws       parentOcc <- liftIO $ getEventSubscribedOcc subd@@ -826,7 +878,7 @@     Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do       subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"       subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef-      let !s = Box subscribedUnsafe+      s <- liftIO $ newBox subscribedUnsafe       ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"       subscribers :: [(Any, Maybe (DSum k), Int, DSum (WrapArg EventSubscribed k))] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(WrapArg k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do         parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws@@ -886,7 +938,7 @@     Just subscribed -> return subscribed     Nothing -> do       subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f-      let !sub = SubscriberFan subscribedUnsafe+      sub <- liftIO $ newSubscriberFan subscribedUnsafe       wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"       subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub       subscribersRef <- liftIO $ newIORef DMap.empty@@ -909,8 +961,8 @@     Nothing -> do       subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"       subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef-      let !i = InvalidatorSwitch subscribedUnsafe-          !sub = SubscriberSwitch subscribedUnsafe+      i <- liftIO $ newInvalidatorSwitch subscribedUnsafe+      sub <- liftIO $ newSubscriberSwitch subscribedUnsafe       wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"       wiRef <- liftIO $ newIORef wi       wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"@@ -951,7 +1003,7 @@     Nothing -> do       subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"       subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef-      let !subOuter = SubscriberCoincidenceOuter subscribedUnsafe+      subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe       wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"       outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter       outerOcc <- liftIO $ getEventSubscribedOcc outerSubd@@ -1287,10 +1339,12 @@   {-# INLINE newRef #-}   {-# INLINE readRef #-}   {-# INLINE writeRef #-}-  {-# INLINE atomicModifyRef #-}   newRef = liftIO . newRef   readRef = liftIO . readRef   writeRef r a = liftIO $ writeRef r a++instance MonadAtomicRef EventM where+  {-# INLINE atomicModifyRef #-}   atomicModifyRef r f = liftIO $ atomicModifyRef r f  newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)@@ -1334,6 +1388,8 @@   newRef = SpiderHost . newRef   readRef = SpiderHost . readRef   writeRef r = SpiderHost . writeRef r++instance MonadAtomicRef SpiderHost where   atomicModifyRef r = SpiderHost . atomicModifyRef r  instance MonadRef SpiderHostFrame where@@ -1341,4 +1397,6 @@   newRef = SpiderHostFrame . newRef   readRef = SpiderHostFrame . readRef   writeRef r = SpiderHostFrame . writeRef r++instance MonadAtomicRef SpiderHostFrame where   atomicModifyRef r = SpiderHostFrame . atomicModifyRef r