reflex 0.3.2 → 0.4.0
raw patch · 10 files changed
+240/−115 lines, 10 filesdep +splitdep ~basedep ~containersdep ~dependent-map
Dependencies added: split
Dependency ranges changed: base, containers, dependent-map, dependent-sum, haskell-src-exts, mtl, primitive, ref-tf, semigroups, syb, transformers
Files
- bench/RunAll.hs +86/−0
- reflex.cabal +24/−4
- src/Data/Functor/Misc.hs +26/−25
- src/Reflex/Class.hs +21/−17
- src/Reflex/Dynamic.hs +27/−17
- src/Reflex/Dynamic/TH.hs +1/−1
- src/Reflex/Host/Class.hs +5/−4
- src/Reflex/Spider/Internal.hs +44/−41
- test/Reflex/Pure.hs +4/−4
- test/Reflex/Test/CrossImpl.hs +2/−2
+ bench/RunAll.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE ConstraintKinds, TypeSynonymInstances, BangPatterns, ScopedTypeVariables, TupleSections, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Criterion.Main+import Criterion.Types++import Reflex+import Reflex.Host.Class++import Reflex.TestPlan+import Reflex.Plan.Reflex++import Reflex.Spider.Internal (SpiderEventHandle)+import qualified Reflex.Bench.Focused as Focused++import Control.Applicative+import Control.DeepSeq (NFData (..))++import System.IO+import System.Mem+import Prelude++type MonadReflexHost' t m = (MonadReflexHost t m, MonadIORef m, MonadIORef (HostFrame t))+++setupFiring :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (Ignore (EventHandle t a), Schedule t)+setupFiring p = do+ (e, s) <- runPlan p+ h <- subscribeEvent e+ return (Ignore h, s)++-- Hack to avoid the NFData constraint for EventHandle which is a synonym+newtype Ignore a = Ignore a+instance NFData (Ignore a) where+ rnf !_ = ()++instance NFData (SpiderEventHandle a) where+ rnf !_ = ()++instance NFData (Behavior t a) where+ rnf !_ = ()++instance NFData (Firing t) where+ rnf !(Firing _ _) = ()++-- Measure the running time+benchFiring :: (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> (String, TestCase) -> Benchmark+benchFiring runHost (name, TestE p) = env setup (\e -> bench name $ whnfIO $ run e) where+ run (Ignore h, s) = runHost (readSchedule s (readEvent' h)) >> performGC+ setup = runHost $ setupFiring p++benchFiring runHost (name, TestB p) = env setup (\e -> bench name $ whnfIO $ run e) where+ run (b, s) = runHost (readSchedule s (sample b)) >> performGC+ setup = runHost $ do+ (b, s) <- runPlan p+ return (b, makeDense s)++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ defaultMainWith (defaultConfig { timeLimit = 10, csvFile = Just "dmap-original.csv" })+ [ benchImpl "spider" runSpiderHost+ ]++benchImpl :: (MonadReflexHost' t m, MonadSample t m) => String -> (forall a. m a -> IO a) -> Benchmark+benchImpl name runHost = bgroup name [ sub 100 40+ , dynamics 100+ , dynamics 1000+ , firing 1000+ , firing 10000+ , merging 10+ , merging 50+ , merging 100 + , merging 200]+ where+ sub n frames = runGroup ("subscribing " ++ show (n, frames)) $ Focused.subscribing n frames+ firing n = runGroup ("firing " ++ show n) $ Focused.firing n+ merging n = runGroup ("merging " ++ show n) $ Focused.merging n+ dynamics n = runGroup ("dynamics " ++ show n) $ Focused.dynamics n++ runGroup name' benchmarks = bgroup name' (benchFiring runHost <$> benchmarks)+++
reflex.cabal view
@@ -1,5 +1,5 @@ Name: reflex-Version: 0.3.2+Version: 0.4.0 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3@@ -17,9 +17,9 @@ hs-source-dirs: src build-depends: base >= 4.7 && < 4.9,- dependent-sum == 0.2.*,- dependent-map == 0.1.*,- semigroups >= 0.16 && < 0.18,+ dependent-sum == 0.3.*,+ dependent-map == 0.2.*,+ semigroups >= 0.16 && < 0.19, mtl >= 2.1 && < 2.3, containers == 0.5.*, these >= 0.4 && < 0.7,@@ -77,6 +77,26 @@ mtl, primitive, criterion == 1.1.*,+ reflex++benchmark saulzar-bench+ type: exitcode-stdio-1.0+ hs-source-dirs: bench test+ main-is: RunAll.hs+ ghc-options: -O2 -rtsopts+ build-depends:+ base,+ containers == 0.5.*,+ ref-tf == 0.4,+ dependent-sum,+ dependent-map,+ transformers >= 0.3 && < 0.5,+ stm == 2.4.*,+ deepseq >= 1.3 && < 1.5,+ mtl,+ primitive,+ criterion == 1.1.*,+ split, reflex source-repository head
src/Data/Functor/Misc.hs view
@@ -8,7 +8,7 @@ import qualified Data.Dependent.Map as DMap import Data.Typeable hiding (Refl) import Data.These-import Data.Maybe+import Control.Monad.Identity data WrapArg :: (k -> *) -> (k -> *) -> * -> * where WrapArg :: f a -> WrapArg g f (g a)@@ -39,37 +39,38 @@ GT -> GGT {-# INLINE sequenceDmap #-}-sequenceDmap :: (Monad m, GCompare f) => DMap (WrapArg m f) -> m (DMap f)-sequenceDmap = DMap.foldrWithKey (\(WrapArg k) mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k v x) (return DMap.empty)+sequenceDmap :: (Monad m, GCompare f) => DMap f m -> m (DMap f Identity)+sequenceDmap = DMap.foldrWithKey (\k mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k (Identity v) x)+ (return DMap.empty) {-# INLINE combineDMapsWithKey #-}-combineDMapsWithKey :: forall f g h i. GCompare f => (forall a. f a -> These (g a) (h a) -> i a) -> DMap (WrapArg g f) -> DMap (WrapArg h f) -> DMap (WrapArg i f)+combineDMapsWithKey :: forall f g h i. GCompare f => (forall (a :: *). f a -> These (g a) (h a) -> i a) -> DMap f g -> DMap f h -> DMap f i combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)- where go :: [DSum (WrapArg g f)] -> [DSum (WrapArg h f)] -> [DSum (WrapArg i f)]- go [] hs = map (\(WrapArg hk :=> hv) -> WrapArg hk :=> f hk (That hv)) hs- go gs [] = map (\(WrapArg gk :=> gv) -> WrapArg gk :=> f gk (This gv)) gs- go gs@((WrapArg gk :=> gv) : gs') hs@((WrapArg hk :=> hv) : hs') = case gk `gcompare` hk of- GLT -> (WrapArg gk :=> f gk (This gv)) : go gs' hs- GEQ -> (WrapArg gk :=> f gk (These gv hv)) : go gs' hs'- GGT -> (WrapArg hk :=> f hk (That hv)) : go gs hs'+ where go :: [DSum f g] -> [DSum f h] -> [DSum f i]+ go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs+ go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs+ go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of+ GLT -> (gk :=> f gk (This gv)) : go gs' hs+ GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'+ GGT -> (hk :=> f hk (That hv)) : go gs hs' -wrapDMap :: (forall a. a -> f a) -> DMap k -> DMap (WrapArg f k)-wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> WrapArg k :=> f v) . DMap.toAscList+wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f+wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> Identity v) -> k :=> f v) . DMap.toAscList -rewrapDMap :: (forall a. f a -> g a) -> DMap (WrapArg f k) -> DMap (WrapArg g k)-rewrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> WrapArg k :=> f v) . DMap.toAscList+rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g+rewrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> f v) . DMap.toAscList -unwrapDMap :: (forall a. f a -> a) -> DMap (WrapArg f k) -> DMap k-unwrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> k :=> f v) . DMap.toAscList+unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity +unwrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> Identity (f v)) . DMap.toAscList -unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap (WrapArg f k) -> DMap k-unwrapDMapMaybe f = DMap.fromDistinctAscList . catMaybes . map (\(WrapArg k :=> v) -> fmap (k :=>) $ f v) . DMap.toAscList+unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity+unwrapDMapMaybe f m = DMap.fromDistinctAscList [k :=> Identity w | (k :=> v) <- DMap.toAscList m, Just w <- [f v]] -mapToDMap :: Map k v -> DMap (Const2 k v)-mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList+mapToDMap :: Map k v -> DMap (Const2 k v) Identity+mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList -mapWithFunctorToDMap :: Map k (f v) -> DMap (WrapArg f (Const2 k v))-mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> WrapArg (Const2 k) :=> v) . Map.toAscList+mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f+mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> (Const2 k) :=> v) . Map.toAscList -dmapToMap :: DMap (Const2 k v) -> Map k v-dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, v)) . DMap.toAscList+dmapToMap :: DMap (Const2 k v) Identity -> Map k v+dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
src/Reflex/Class.hs view
@@ -45,9 +45,9 @@ -- | A monad for doing complex pull-based calculations efficiently type PullM t :: * -> * -- | Merge a collection of events; the resulting Event will only occur if at least one input event is occuring, and will contain all of the input keys that are occurring simultaneously- merge :: GCompare k => DMap (WrapArg (Event t) k) -> Event t (DMap k) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty+ merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events- fan :: GCompare k => Event t (DMap k) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it+ fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it -- | Create an Event that will occur whenever the currently-selected input Event occurs switch :: Behavior t (Event t a) -> Event t a -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring@@ -58,7 +58,7 @@ sample :: Behavior t a -> m a class MonadSample t m => MonadHold t m where- -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs+ -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs. The update takes effect immediately after the Event occurs; if the occurrence that sets the Behavior (or one that is simultaneous with it) is used to sample the Behavior, it will see the *old* value of the Behavior, not the new one. hold :: a -> Event t a -> m (Behavior t a) newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a }@@ -273,30 +273,30 @@ LeftTag -> showString "LeftTag" RightTag -> showString "RightTag" -instance (Show l, Show r) => ShowTag (EitherTag l r) where- showTaggedPrec t n a = case t of+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where+ showTaggedPrec t n (Identity a) = case t of 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 :: Either a b -> DSum (EitherTag a b) Identity eitherToDSum = \case- Left a -> LeftTag :=> a- Right b -> RightTag :=> b+ Left a -> (LeftTag :=> Identity a)+ Right b -> (RightTag :=> Identity b) -- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.-dsumToEither :: DSum (EitherTag a b) -> Either a b+dsumToEither :: DSum (EitherTag a b) Identity -> Either a b dsumToEither = \case- LeftTag :=> a -> Left a- RightTag :=> b -> Right b+ (LeftTag :=> Identity a) -> Left a+ (RightTag :=> Identity b) -> Right b -- | Extract the values of a 'DMap' of 'EitherTag's.-dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b)+dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b) dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of (Nothing, Nothing) -> Nothing- (Just a, Nothing) -> Just $ This a- (Nothing, Just b) -> Just $ That b- (Just a, Just b) -> Just $ These a b+ (Just (Identity a), Nothing) -> Just $ This a+ (Nothing, Just (Identity b)) -> Just $ That b+ (Just (Identity a), Just (Identity 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@@ -320,7 +320,11 @@ -- 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+mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)+ . merge+ . DMap.fromDistinctAscList+ . map (\(k, v) -> (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@@ -356,7 +360,7 @@ instance Reflex t => Align (Event t) where nil = never- align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb]+ align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb] -- | Create a new 'Event' that only occurs if the supplied 'Event' -- occurs and the 'Behavior' is true at the time of occurence.
src/Reflex/Dynamic.hs view
@@ -93,6 +93,11 @@ -- | 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.+--+-- Although @Dynamic@ logically has a 'Functor' instance, currently it can\'t+-- be implemented without potentially requiring the mapped function to be+-- evaluated twice. Instead, you can use 'mapDyn', which runs in a 'MonadHold'+-- instance, to achieve the same result. data Dynamic t a = Dynamic (Behavior t a) (Event t a) @@ -222,26 +227,26 @@ -- | 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+ ddm :: Dynamic t (DMap (Const2 Int a) Identity) <- distributeDMapOverDyn . DMap.fromList . map (\(k, v) -> Const2 k :=> v) $ zip [0 :: Int ..] es+ mapDyn (mconcat . map (\(Const2 _ :=> Identity 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 :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity)) distributeDMapOverDyn dm = case DMap.toList dm of [] -> return $ constDyn DMap.empty- [WrapArg k :=> v] -> mapDyn (DMap.singleton k) v+ [k :=> v] -> mapDyn (DMap.singleton k . Identity) v _ -> do let edmPre = merge $ rewrapDMap updated dm- edm :: Event t (DMap k) = flip push edmPre $ \o -> return . Just =<< do+ edm :: Event t (DMap k Identity) = flip push edmPre $ \o -> return . Just =<< do let f _ = \case This origDyn -> sample $ current origDyn That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap" These _ (Identity newVal) -> return newVal sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)- dm0 :: Behavior t (DMap k) = pull $ do- liftM DMap.fromList $ forM (DMap.toList dm) $ \(WrapArg k :=> dv) -> liftM (k :=>) $ sample $ current dv- bbdm :: Behavior t (Behavior t (DMap k)) <- hold dm0 $ fmap constant edm+ dm0 :: Behavior t (DMap k Identity) = pull $ do+ liftM DMap.fromList . forM (DMap.toList dm) $ \(k :=> dv) -> liftM ((k :=>) . Identity) . sample $ current dv+ bbdm :: Behavior t (Behavior t (DMap k Identity)) <- hold dm0 $ fmap constant edm let bdm = pull $ sample =<< sample bbdm return $ Dynamic bdm edm @@ -379,7 +384,12 @@ -- | 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))+demux k = Demux (current k)+ (fan $ attachWith (\k0 k1 -> if k0 == k1 + then DMap.empty+ else DMap.fromList [Const2 k0 :=> Identity False,+ Const2 k1 :=> Identity 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)@@ -417,16 +427,16 @@ HHeadPtr :: HListPtr (h ': t) h HTailPtr :: HListPtr t a -> HListPtr (h ': t) a -fhlistToDMap :: forall f l. FHList f l -> DMap (WrapArg f (HListPtr l))+fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f fhlistToDMap = DMap.fromList . go- where go :: forall l'. FHList f l' -> [DSum (WrapArg f (HListPtr l'))]+ where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f] go = \case FHNil -> []- FHCons h t -> (WrapArg HHeadPtr :=> h) : map (\(WrapArg p :=> v) -> WrapArg (HTailPtr p) :=> v) (go t)+ FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> (HTailPtr p) :=> v) (go t) class RebuildSortedHList l where- rebuildSortedFHList :: [DSum (WrapArg f (HListPtr l))] -> FHList f l- rebuildSortedHList :: [DSum (HListPtr l)] -> HList l+ rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l+ rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l instance RebuildSortedHList '[] where rebuildSortedFHList l = case l of@@ -438,13 +448,13 @@ instance RebuildSortedHList t => RebuildSortedHList (h ': t) where rebuildSortedFHList l = case l of- ((WrapArg HHeadPtr :=> h) : t) -> FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t+ ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected" rebuildSortedHList l = case l of- ((HHeadPtr :=> h) : t) -> HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t+ ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected" -dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l+dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l dmapToHList = rebuildSortedHList . DMap.toList distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
src/Reflex/Dynamic/TH.hs view
@@ -22,7 +22,7 @@ Just (Refl :: d :~: Exp) | AppE (VarE m) eInner <- d , m == 'unqMarker- -> do n <- lift $ newName "dyn"+ -> do n <- lift $ newName "dynamicQuotedExpressionVariable" modify ((n, eInner):) return $ VarE n _ -> gmapM f d
src/Reflex/Host/Class.hs view
@@ -6,6 +6,7 @@ import Control.Applicative import Control.Monad import Control.Monad.Fix+import Control.Monad.Identity import Control.Monad.Trans import Control.Monad.Trans.Reader (ReaderT()) import Control.Monad.Trans.Writer (WriterT())@@ -84,7 +85,7 @@ -- The main loop waits for external events to happen (such as keyboard input or a mouse click) -- and then fires the corresponding events using this function. The read callback can be used -- to read output events and perform a corresponding response action to the external event.- fireEventsAndRead :: [DSum (EventTrigger t)] -> (ReadPhase m a) -> m a+ fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> (ReadPhase m a) -> m a -- | Run a frame without any events firing. --@@ -96,7 +97,7 @@ runHostFrame :: HostFrame t a -> m a -- | Like 'fireEventsAndRead', but without reading any events.-fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t)] -> m ()+fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t) Identity] -> m () fireEvents dm = fireEventsAndRead dm $ return () {-# INLINE fireEvents #-} @@ -120,14 +121,14 @@ mt <- readRef mtRef case mt of Nothing -> return ()- Just trigger -> fireEvents [trigger :=> input]+ Just trigger -> fireEvents [trigger :=> Identity input] fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b) fireEventRefAndRead mtRef input e = do mt <- readRef mtRef case mt of Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire- Just trigger -> fireEventsAndRead [trigger :=> input] $ do+ Just trigger -> fireEventsAndRead [trigger :=> Identity input] $ do mGetValue <- readEvent e case mGetValue of Nothing -> return Nothing
src/Reflex/Spider/Internal.hs view
@@ -9,19 +9,20 @@ import Data.Foldable import Data.Traversable import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)+import Control.Monad.Identity hiding (mapM, mapM_, forM_, forM, sequence) import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence) import GHC.Exts import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2 import Data.Dependent.Map (DMap, DSum (..)) import qualified Data.Dependent.Map as DMap import Data.GADT.Compare-import Data.Functor.Misc import Data.Maybe import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Control.Monad.Ref import Control.Monad.Exception import Data.Monoid ((<>))+import Data.Coerce import System.IO.Unsafe import Unsafe.Coerce@@ -139,7 +140,7 @@ clears <- asks eventEnvClears liftIO $ modifyIORef' clears (SomeMaybeIORef r :) -scheduleRootClear :: IORef (DMap k) -> EventM ()+scheduleRootClear :: IORef (DMap k Identity) -> EventM () scheduleRootClear r = EventM $ do clears <- asks eventEnvRootClears liftIO $ modifyIORef' clears (SomeDMapIORef r :)@@ -223,8 +224,8 @@ } data Root (k :: * -> *)- = Root { rootOccurrence :: !(IORef (DMap k)) -- The currently-firing occurrence of this event- , rootSubscribed :: !(IORef (DMap (WrapArg RootSubscribed k)))+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event+ , rootSubscribed :: !(IORef (DMap k RootSubscribed)) , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ())) } @@ -251,12 +252,12 @@ } data MergeSubscribed k- = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k)))- , mergeSubscribedAccum :: !(IORef (DMap k)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence+ = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))+ , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence , mergeSubscribedHeight :: !(IORef Int)- , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k)])+ , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k Identity)]) , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory- , mergeSubscribedParents :: !(DMap (WrapArg EventSubscribed k))+ , mergeSubscribedParents :: !(DMap k EventSubscribed) #ifdef DEBUG_NODEIDS , mergeSubscribedNodeId :: Int #endif@@ -264,7 +265,7 @@ --TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key) data Merge k- = Merge { mergeParents :: !(DMap (WrapArg Event k))+ = Merge { mergeParents :: !(DMap k Event) , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk? } @@ -283,16 +284,16 @@ GGT -> GGT data FanSubscribed k- = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))- , fanSubscribedParent :: !(EventSubscribed (DMap k))- , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k))+ = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k) Identity))+ , fanSubscribedParent :: !(EventSubscribed (DMap k Identity))+ , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k Identity)) #ifdef DEBUG_NODEIDS , fanSubscribedNodeId :: Int #endif } data Fan k- = Fan { fanParent :: !(Event (DMap k))+ = Fan { fanParent :: !(Event (DMap k Identity)) , fanSubscribed :: !(IORef (Maybe (FanSubscribed k))) } @@ -354,7 +355,7 @@ data Subscriber a = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b) | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?- | forall k. (GCompare k, a ~ DMap k) => SubscriberFan (FanSubscribed k)+ | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k) | SubscriberHold !(Hold a) | SubscriberSwitch (SwitchSubscribed a) | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)@@ -374,7 +375,7 @@ = forall k. GCompare k => EventRoot !(k a) !(Root k) | EventNever | forall b. EventPush !(Push b a)- | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)+ | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k) | forall k. GCompare k => EventFan !(k a) !(Fan k) | EventSwitch !(Switch a) | EventCoincidence !(Coincidence a)@@ -393,7 +394,7 @@ = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a) | EventSubscribedNever | forall b. EventSubscribedPush !(PushSubscribed b a)- | forall k. (GCompare k, a ~ DMap k) => EventSubscribedMerge !(MergeSubscribed k)+ | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k) | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k) | EventSubscribedSwitch !(SwitchSubscribed a) | EventSubscribedCoincidence !(CoincidenceSubscribed a)@@ -424,7 +425,7 @@ newSubscriberHold h = return $! SubscriberHold h {-# NOINLINE newSubscriberFan #-}-newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k))+newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity)) newSubscriberFan subd = return $! SubscriberFan subd {-# NOINLINE newSubscriberSwitch #-}@@ -519,7 +520,7 @@ liftIO $ modifyIORef' subscribersRef (++stillAlive) -- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors-run :: [DSum RootTrigger] -> ResultM b -> IO b+run :: [DSum RootTrigger Identity] -> ResultM b -> IO b run roots after = do when debugPropagate $ putStrLn "Running an event frame" result <- runFrame $ do@@ -532,7 +533,7 @@ then do scheduleRootClear occRef return $ Just r else return Nothing- forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> a) -> do+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do propagateAndUpdateSubscribersRef subscribersRef a delayedRef <- EventM $ asks eventEnvDelayedMerges let go = do@@ -565,7 +566,7 @@ data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a)) -data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k))+data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k Identity)) data SomeAssignment = forall a. SomeAssignment (Hold a) a @@ -611,7 +612,7 @@ SubscriberMerge k subscribed -> do when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed- liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k a oldM+ liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k (Identity a) oldM when (DMap.null oldM) $ do -- Only schedule the firing once height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed --TODO: assertions about height@@ -622,17 +623,19 @@ subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing" --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large- forM_ (DMap.toList a) $ \(k :=> v) -> case DMap.lookup (FanSubscriberKey k) subs of+ forM_ (DMap.toList a) $ \(k :=> Identity v) -> case DMap.lookup (FanSubscriberKey k) subs of Nothing -> do when debugPropagate $ liftIO $ putStrLn "No subscriber for key" return ()- Just subsubs -> do+ Just (Identity subsubs) -> do _ <- propagate v subsubs --TODO: use the value of this return () --TODO: The following is way too slow to do all the time- subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> subsubs) -> do+ subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> Identity subsubs) -> do subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())- return $ if null subsubs' then Nothing else Just $ FanSubscriberKey k :=> subsubs') :: DSum (FanSubscriberKey k) -> IO (Maybe (DSum (FanSubscriberKey k))))+ return $ if null subsubs'+ then Nothing+ else Just $ FanSubscriberKey k :=> Identity subsubs') :: DSum (FanSubscriberKey k) Identity -> IO (Maybe (DSum (FanSubscriberKey k) Identity))) liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs' SubscriberHold h -> do invalidators <- liftIO $ readIORef $ holdInvalidators h@@ -731,7 +734,7 @@ readEvent :: Event a -> ResultM (Maybe a) readEvent e = case e of- EventRoot k r -> liftIO $ liftM (DMap.lookup k) $ readIORef $ rootOccurrence r+ EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r EventNever -> return Nothing EventPush p -> do subscribed <- getPushSubscribed p@@ -747,7 +750,7 @@ return result EventFan k f -> do parentOcc <- readEvent $ fanParent f- return $ DMap.lookup k =<< parentOcc+ return . coerce $ DMap.lookup k =<< parentOcc EventSwitch s -> do subscribed <- getSwitchSubscribed s liftIO $ do@@ -794,7 +797,7 @@ modifyIORef' (pushSubscribedSubscribers subscribed) (ws:) EventSubscribedFan k subscribed -> do when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"- modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (++) (FanSubscriberKey k) [ws]+ modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (liftA2 (++)) (FanSubscriberKey k) (Identity [ws]) EventSubscribedMerge subscribed -> do when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge" modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)@@ -812,7 +815,7 @@ EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed EventSubscribedFan k subscribed -> do parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed- let occ = DMap.lookup k =<< parentOcc+ let occ = coerce $ DMap.lookup k =<< parentOcc return occ EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed@@ -841,18 +844,18 @@ getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a) getRootSubscribed k r = do mSubscribed <- liftIO $ readIORef $ rootSubscribed r- case DMap.lookup (WrapArg k) mSubscribed of+ case DMap.lookup k mSubscribed of Just subscribed -> return subscribed Nothing -> liftIO $ do subscribersRef <- newIORef []- subscribed <- newRootSubscribed (liftM (DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef+ subscribed <- newRootSubscribed (liftM (coerce . DMap.lookup k) $ readIORef $ 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 k $ RootTrigger (subscribersRef, rootOccurrence r, k) addFinalizer subscribed $ do when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should -- putStrLn "Uninit root" uninit- liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert (WrapArg k) subscribed+ liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert k subscribed return subscribed -- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in@@ -894,11 +897,11 @@ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef 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+ subscribers :: [(Any, Maybe (DSum k Identity), Int, DSum k EventSubscribed)] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd- return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (k :=>) parentOcc, height, WrapArg k :=> parentSubd)+ return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (\x -> k :=> Identity x) parentOcc, height, k :=> parentSubd) let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers subscriberHeights = map (\(_, _, x, _) -> x) subscribers myHeight =@@ -1048,7 +1051,7 @@ liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed return subscribed -merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)+merge :: GCompare k => DMap k Event -> Event (DMap k Identity) merge m = EventMerge $ Merge { mergeParents = m , mergeSubscribed = unsafeNewIORef m Nothing@@ -1056,7 +1059,7 @@ newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a } -fan :: GCompare k => Event (DMap k) -> EventSelector k+fan :: GCompare k => Event (DMap k Identity) -> EventSelector k fan e = let f = Fan { fanParent = e@@ -1154,7 +1157,7 @@ SubscriberFan subscribed -> do when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed subscribers <- readIORef $ fanSubscribedSubscribers subscribed- forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())+ forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ()) when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" SubscriberHold _ -> return () SubscriberSwitch subscribed -> do@@ -1205,7 +1208,7 @@ SubscriberFan subscribed -> do when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed subscribers <- readIORef $ fanSubscribedSubscribers subscribed- forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())+ forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ()) when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" SubscriberHold _ -> return () SubscriberSwitch subscribed -> do@@ -1237,7 +1240,7 @@ calculateMergeHeight :: MergeSubscribed k -> IO Int calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do- heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(WrapArg _ :=> es) -> do+ heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(_ :=> es) -> do readIORef $ eventSubscribedHeightRef es return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum' @@ -1316,7 +1319,7 @@ constant = SpiderBehavior . BehaviorConst push f = SpiderEvent. push f . unSpiderEvent pull = SpiderBehavior . pull- merge = SpiderEvent . merge . (unsafeCoerce :: DMap (WrapArg (R.Event Spider) k) -> DMap (WrapArg Event k))+ merge = SpiderEvent . merge . (unsafeCoerce :: DMap k (R.Event Spider) -> DMap k Event) fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e)) switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent@@ -1340,7 +1343,7 @@ {-# INLINE hold #-} hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e) -data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k), k a)+data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k Identity), k a) newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a } instance R.MonadSubscribeEvent Spider SpiderHostFrame where
test/Reflex/Pure.hs view
@@ -9,7 +9,7 @@ import Reflex.Class import Data.Functor.Misc-+import Control.Monad.Identity import Control.Monad import Data.MemoTrie import Data.Dependent.Map (DMap, GCompare)@@ -40,15 +40,15 @@ pull :: PullM (Pure t) a -> Behavior (Pure t) a pull = Behavior . memo - merge :: GCompare k => DMap (WrapArg (Event (Pure t)) k) -> Event (Pure t) (DMap k)+ merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity) merge events = Event $ memo $ \t -> let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events in if DMap.null currentOccurrences then Nothing else Just currentOccurrences - fan :: GCompare k => Event (Pure t) (DMap k) -> EventSelector (Pure t) k- fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
test/Reflex/Test/CrossImpl.hs view
@@ -71,12 +71,12 @@ let times = relevantTestingTimes (bMap, eMap) liftIO performGC outputs <- forM times $ \t -> do- forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> val]) =<< readRef rbTrigger+ forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger bOutput <- sample b' eOutput <- liftM join $ forM (Map.lookup t eMap) $ \val -> do mret <- readRef reTrigger let firing = case mret of- Just ret -> [ret :=> val]+ Just ret -> [ret :=> Identity val] Nothing -> [] fireEventsAndRead firing $ sequence =<< readEvent e'Handle liftIO performGC