reflex 0.2 → 0.3
raw patch · 8 files changed
+649/−98 lines, 8 filesdep +MemoTriedep +exception-transformersdep +transformers-compatdep ~basedep ~containersdep ~dependent-map
Dependencies added: MemoTrie, exception-transformers, transformers-compat
Dependency ranges changed: base, containers, dependent-map, mtl, ref-tf, these, transformers
Files
- reflex.cabal +22/−4
- src/Data/Functor/Misc.hs +6/−2
- src/Reflex/Class.hs +72/−7
- src/Reflex/Dynamic.hs +36/−12
- src/Reflex/Host/Class.hs +152/−24
- src/Reflex/Spider/Internal.hs +87/−49
- test/Reflex/Pure.hs +46/−0
- test/Reflex/Test/CrossImpl.hs +228/−0
reflex.cabal view
@@ -1,5 +1,5 @@ Name: reflex-Version: 0.2+Version: 0.3 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3@@ -23,9 +23,12 @@ mtl >= 2.1 && < 2.3, containers == 0.5.*, these == 0.4.*,- primitive == 0.5.*,+ primitive >= 0.5 && < 0.7, template-haskell >= 2.9 && < 2.11,- ref-tf == 0.4.*+ ref-tf == 0.4.*,+ exception-transformers == 0.4.*,+ transformers >= 0.2,+ transformers-compat >= 0.3 exposed-modules: Reflex,@@ -38,8 +41,23 @@ Data.Functor.Misc other-extensions: TemplateHaskell- ghc-prof-options: -fprof-auto ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2++test-suite cross-impl+ type: exitcode-stdio-1.0+ main-is: Reflex/Test/CrossImpl.hs+ other-modules:+ Reflex.Pure+ ghc-options: -O2 -main-is Reflex.Test.CrossImpl.test+ hs-source-dirs: test+ build-depends:+ base,+ reflex,+ ref-tf,+ mtl,+ containers,+ dependent-map,+ MemoTrie == 0.6.* benchmark spider-bench type: exitcode-stdio-1.0
src/Data/Functor/Misc.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, PolyKinds #-} module Data.Functor.Misc where import Data.GADT.Compare@@ -8,8 +8,9 @@ import qualified Data.Dependent.Map as DMap import Data.Typeable hiding (Refl) import Data.These+import Data.Maybe -data WrapArg :: (* -> *) -> (* -> *) -> * -> * where+data WrapArg :: (k -> *) -> (k -> *) -> * -> * where WrapArg :: f a -> WrapArg g f (g a) instance GEq f => GEq (WrapArg g f) where@@ -60,6 +61,9 @@ 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++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 mapToDMap :: Map k v -> DMap (Const2 k v) mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
src/Reflex/Class.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase #-} module Reflex.Class where -import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)-+import Control.Applicative import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_) import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_) import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Control.Monad.Trans.Writer (WriterT())+import Control.Monad.Trans.Except (ExceptT())+import Control.Monad.Trans.Cont (ContT())+import Control.Monad.Trans.RWS (RWST()) import Data.List.NonEmpty (NonEmpty (..)) import Data.These import Data.Align@@ -17,10 +20,14 @@ import qualified Data.Dependent.Map as DMap import Data.Functor.Misc import Data.Semigroup+import Data.Traversable +-- Note: must come last to silence warnings due to AMP on GHC < 7.10+import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)+ import Debug.Trace (trace) -class (MonadHold t (PushM t), MonadSample t (PullM t), Functor (Event t), Functor (Behavior t)) => Reflex t where+class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Functor (Event t), Functor (Behavior t)) => Reflex t where -- | A container for a value that can change over time. Behaviors can be sampled at will, but it is not possible to be notified when they change data Behavior t :: * -> * -- | A stream of occurrences. During any given frame, an Event is either occurring or not occurring; if it is occurring, it will contain a value of the given type (its "occurrence type")@@ -39,14 +46,14 @@ 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- -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events + -- | 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 -- | 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 coincidence :: Event t (Event t a) -> Event t a -class Monad m => MonadSample t m | m -> t where+class (Applicative m, Monad m) => MonadSample t m | m -> t where -- | Get the current value in the Behavior sample :: Behavior t a -> m a @@ -66,6 +73,36 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where hold a0 = lift . hold a0 +instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where+ sample = lift . sample++instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where+ hold a0 = lift . hold a0++instance MonadSample t m => MonadSample t (StateT s m) where+ sample = lift . sample++instance MonadHold t m => MonadHold t (StateT s m) where+ hold a0 = lift . hold a0++instance MonadSample t m => MonadSample t (ExceptT e m) where+ sample = lift . sample++instance MonadHold t m => MonadHold t (ExceptT e m) where+ hold a0 = lift . hold a0++instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where+ sample = lift . sample++instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where+ hold a0 = lift . hold a0++instance MonadSample t m => MonadSample t (ContT r m) where+ sample = lift . sample++instance MonadHold t m => MonadHold t (ContT r m) where+ hold a0 = lift . hold a0+ -------------------------------------------------------------------------------- -- Convenience functions --------------------------------------------------------------------------------@@ -73,7 +110,7 @@ -- | 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+pushAlways f = push (liftM Just . f) -- | Flipped version of 'fmap'. ffor :: Functor f => f a -> (a -> b) -> f b@@ -82,6 +119,28 @@ instance Reflex t => Functor (Behavior t) where fmap f = pull . liftM f . sample +instance Reflex t => Applicative (Behavior t) where+ pure = constant+ f <*> x = pull $ sample f `ap` sample x+ _ *> b = b+ a <* _ = a++instance Reflex t => Monad (Behavior t) where+ a >>= f = pull $ sample a >>= sample . f+ -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail. Since we can't examine Behaviors other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above.+ return = constant+ fail = error "Monad (Behavior t) does not support fail"++instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where+ a <> b = pull $ liftM2 (<>) (sample a) (sample b)+ sconcat = pull . liftM sconcat . mapM sample+ times1p n = fmap $ times1p n++instance (Reflex t, Monoid a) => Monoid (Behavior t a) where+ mempty = constant mempty+ mappend a b = pull $ liftM2 mappend (sample a) (sample b)+ mconcat = pull . liftM mconcat . mapM 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@@ -239,7 +298,7 @@ -- '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+appendEvents e1 e2 = 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)@@ -299,3 +358,9 @@ -- 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++-- | Create a new behavior given a starting behavior and switch to a the+-- behvior carried by the event when it fires.+switcher :: (Reflex t, MonadHold t m)+ => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)+switcher b eb = pull . (sample <=< sample) <$> hold b eb
src/Reflex/Dynamic.hs view
@@ -156,16 +156,22 @@ -- 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)+foldDyn f = foldDynMaybe $ \o v -> Just $ 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+foldDynM f = foldDynMaybeM $ \o v -> liftM Just $ f o v++foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)+foldDynMaybe f = foldDynMaybeM $ \o v -> return $ f o v++foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)+foldDynMaybeM f z e = do rec let e' = flip push e $ \o -> do v <- sample b'- liftM Just $ f o v+ f o v b' <- hold z e' return $ Dynamic b' e' @@ -421,12 +427,20 @@ rebuildSortedHList :: [DSum (HListPtr l)] -> HList l instance RebuildSortedHList '[] where- rebuildSortedFHList [] = FHNil- rebuildSortedHList [] = HNil+ rebuildSortedFHList l = case l of+ [] -> FHNil+ _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"+ rebuildSortedHList l = case l of+ [] -> HNil+ _ : _ -> error "rebuildSortedHList{'[]}: empty list expected" instance RebuildSortedHList t => RebuildSortedHList (h ': t) where- rebuildSortedFHList ((WrapArg HHeadPtr :=> h) : t) = FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t- rebuildSortedHList ((HHeadPtr :=> h) : t) = HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t+ rebuildSortedFHList l = case l of+ ((WrapArg HHeadPtr :=> h) : t) -> FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg 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+ _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected" dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l dmapToHList = rebuildSortedHList . DMap.toList@@ -449,12 +463,16 @@ instance AllAreFunctors f '[] where type FunctorList f '[] = '[]- toFHList HNil = FHNil+ toFHList l = case l of+ HNil -> FHNil+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 fromFHList FHNil = HNil instance AllAreFunctors f t => AllAreFunctors f (h ': t) where type FunctorList f (h ': t) = f h ': FunctorList f t- toFHList (a `HCons` b) = a `FHCons` toFHList b+ toFHList l = case l of+ a `HCons` b -> a `FHCons` toFHList b+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 fromFHList (a `FHCons` b) = a `HCons` fromFHList b collectDyn :: ( RebuildSortedHList (HListElems b)@@ -475,14 +493,20 @@ instance IsHList (a, b) where type HListElems (a, b) = [a, b] toHList (a, b) = hBuild a b- fromHList (a `HCons` b `HCons` HNil) = (a, b)+ fromHList l = case l of+ a `HCons` b `HCons` HNil -> (a, b)+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 instance IsHList (a, b, c, d) where type HListElems (a, b, c, d) = [a, b, c, d] toHList (a, b, c, d) = hBuild a b c d- fromHList (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a, b, c, d)+ fromHList l = case l of+ a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 instance IsHList (a, b, c, d, e, f) where type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f] toHList (a, b, c, d, e, f) = hBuild a b c d e f- fromHList (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a, b, c, d, e, f)+ fromHList l = case l of+ a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
src/Reflex/Host/Class.hs view
@@ -1,44 +1,109 @@-{-# LANGUAGE ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, FunctionalDependencies #-}+{-# LANGUAGE ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, FunctionalDependencies, FlexibleContexts #-} module Reflex.Host.Class where -import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)- import Reflex.Class -import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)-import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Control.Applicative+import Control.Monad.Fix+import Control.Monad.Trans+import Control.Monad.Trans.Reader (ReaderT())+import Control.Monad.Trans.Writer (WriterT())+import Control.Monad.Trans.Cont (ContT())+import Control.Monad.Trans.Except (ExceptT())+import Control.Monad.Trans.RWS (RWST())+import Control.Monad.Trans.State (StateT()) import Data.Dependent.Sum (DSum)+import Data.Monoid+import Data.GADT.Compare import Control.Monad.Ref -class Reflex t => ReflexHost t where+-- Note: this import must come last to silence warnings from AMP+import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)++-- | Framework implementation support class for the reflex implementation represented by @t@.+class (Reflex t, MonadReflexCreateTrigger t (HostFrame t), MonadSample t (HostFrame t), MonadHold t (HostFrame t), MonadFix (HostFrame t), MonadSubscribeEvent t (HostFrame t)) => ReflexHost t where type EventTrigger t :: * -> * type EventHandle t :: * -> * type HostFrame t :: * -> * -class (ReflexHost t, Monad m) => MonadReadEvent t m | m -> t where+-- | Monad in which Events can be 'subscribed'. This forces all underlying event sources to be initialized, so that the event will fire whenever it ought to. Events must be subscribed before they are read using readEvent+class (Reflex t, Monad m) => MonadSubscribeEvent t m | m -> t where+ -- | Subscribe to an event and set it up if needed.+ --+ -- This function will create a new 'EventHandle' from an 'Event'. This handle may then be used via+ -- 'readEvent' in the read callback of 'fireEventsAndRead'.+ --+ -- If the event wasn't subscribed to before (either manually or through a dependent event or behavior)+ -- then this function will cause the event and all dependencies of this event to be set up.+ -- For example, if the event was created by 'newEventWithTrigger', then it's callback will be executed.+ --+ -- It's safe to call this function multiple times.+ subscribeEvent :: Event t a -> m (EventHandle t a)++-- | Monad that allows to read events' values.+class (ReflexHost t, Applicative m, Monad m) => MonadReadEvent t m | m -> t where+ -- | Read the value of an 'Event' from an 'EventHandle' (created by calling 'subscribeEvent').+ --+ -- After event propagation is done, all events can be in two states: either they are firing with some value or they are not firing.+ -- In the former case, this function returns @Just act@, where @act@ in an action to read the current value of+ -- the event. In the latter case, the function returns @Nothing@.+ --+ -- This function is normally used in the calllback for 'fireEventsAndRead'. 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).+-- | A monad where new events feed from external sources can be created.+class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where+ -- | Creates a root '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.+ -- that depends on the subscription) the given callback function is run and+ -- passed a trigger. The callback function can then set up the event source in IO.+ -- After this is done, the callback function must return an accompanying teardown action.+ -- -- Any time between setup and teardown the trigger can be used to fire- -- the event.+ -- the event, by passing it to 'fireEventsAndRead'.+ --+ -- Note: An event may be set up multiple times. So after the teardown action is executed, the event may still be set up again in the future. newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)+ newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k) -class (Monad m, ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexHost t m | m -> t where- fireEventsAndRead :: [DSum (EventTrigger t)] -> (forall m'. (MonadReadEvent t m') => m' a) -> m a- subscribeEvent :: Event t a -> m (EventHandle t a) --TODO: Return a handle, and use them in fireEventsAnRead- runFrame :: PushM t a -> m a+class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, MonadReadEvent t (ReadPhase m), MonadSample t (ReadPhase m), MonadHold t (ReadPhase m)) => MonadReflexHost t m | m -> t where+ type ReadPhase m :: * -> *+ -- | Propagate some events firings and read the values of events afterwards.+ --+ -- This function will create a new frame to fire the given events. It will then update all+ -- dependent events and behaviors. After that is done, the given callback is executed which+ -- allows to read the final values of events and check whether they have fired in this frame or+ -- not.+ --+ -- All events that are given are fired at the same time.+ --+ -- This function is typically used in the main loop of a reflex framework implementation.+ -- 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++ -- | Run a frame without any events firing.+ --+ -- This function should be used when you want to use 'sample' and 'hold' when no events are currently firing.+ -- Using this function in that case can improve performance, since the implementation can assume that no events+ -- are firing when 'sample' or 'hold' are called.+ --+ -- This function is commonly used to set up the basic event network when the application starts up. runHostFrame :: HostFrame t a -> m a +-- | Like 'fireEventsAndRead', but without reading any events. fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t)] -> m ()-{-# INLINE fireEvents #-} fireEvents dm = fireEventsAndRead dm $ return ()+{-# INLINE fireEvents #-} -{-# INLINE newEventWithTriggerRef #-}+-- | Create a new event and store its trigger in an 'IORef' while it's active.+--+-- An event is only active between the set up (when it's first subscribed to) and the teardown phases (when noboby is subscribing the event anymore).+-- This function returns an Event and an 'IORef'. As long as the event is active, the 'IORef' will contain 'Just' the event trigger to+-- trigger this event. When the event is not active, the 'IORef' will contain 'Nothing'. This allows event sources to be more efficient,+-- since they don't need to produce events when nobody is listening. newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a))) newEventWithTriggerRef = do rt <- newRef Nothing@@ -46,17 +111,80 @@ writeRef rt $ Just t return $ writeRef rt Nothing return (e, rt)+{-# INLINE newEventWithTriggerRef #-} -------------------------------------------------------------------------------- -- Instances -------------------------------------------------------------------------------- -instance (Reflex t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (ReaderT r m) where- newEventWithTrigger initializer = do- lift $ newEventWithTrigger initializer+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ReaderT r m) where+ newEventWithTrigger = lift . newEventWithTrigger+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer -instance (Reflex t, MonadReflexHost t m) => MonadReflexHost t (ReaderT r m) where+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ReaderT r m) where+ subscribeEvent = lift . subscribeEvent++instance MonadReflexHost t m => MonadReflexHost t (ReaderT r m) where+ type ReadPhase (ReaderT r m) = ReadPhase m fireEventsAndRead dm a = lift $ fireEventsAndRead dm a+ runHostFrame = lift . runHostFrame++instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (WriterT w m) where+ newEventWithTrigger = lift . newEventWithTrigger+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer++instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (WriterT w m) where subscribeEvent = lift . subscribeEvent- runFrame = lift . runFrame++instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (WriterT w m) where+ type ReadPhase (WriterT w m) = ReadPhase m+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a+ runHostFrame = lift . runHostFrame++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StateT s m) where+ newEventWithTrigger = lift . newEventWithTrigger+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer++instance MonadSubscribeEvent t m => MonadSubscribeEvent t (StateT r m) where+ subscribeEvent = lift . subscribeEvent++instance MonadReflexHost t m => MonadReflexHost t (StateT s m) where+ type ReadPhase (StateT s m) = ReadPhase m+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a+ runHostFrame = lift . runHostFrame++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ContT r m) where+ newEventWithTrigger = lift . newEventWithTrigger+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer++instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ContT r m) where+ subscribeEvent = lift . subscribeEvent++instance MonadReflexHost t m => MonadReflexHost t (ContT r m) where+ type ReadPhase (ContT r m) = ReadPhase m+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a+ runHostFrame = lift . runHostFrame++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ExceptT e m) where+ newEventWithTrigger = lift . newEventWithTrigger+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer++instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ExceptT r m) where+ subscribeEvent = lift . subscribeEvent++instance MonadReflexHost t m => MonadReflexHost t (ExceptT e m) where+ type ReadPhase (ExceptT e m) = ReadPhase m+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a+ runHostFrame = lift . runHostFrame++instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (RWST r w s m) where+ newEventWithTrigger = lift . newEventWithTrigger+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer++instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (RWST r w s m) where+ subscribeEvent = lift . subscribeEvent++instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (RWST r w s m) where+ type ReadPhase (RWST r w s m) = ReadPhase m+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a runHostFrame = lift . runHostFrame
src/Reflex/Spider/Internal.hs view
@@ -1,8 +1,6 @@-{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase #-}+{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators #-} module Reflex.Spider.Internal where -import Prelude hiding (mapM, mapM_, any, sequence, concat)- import qualified Reflex.Class as R import qualified Reflex.Host.Class as R @@ -13,9 +11,7 @@ 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 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@@ -24,12 +20,16 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Control.Monad.Ref+import Control.Monad.Exception import Data.Monoid ((<>)) import System.IO.Unsafe import Unsafe.Coerce import Control.Monad.Primitive +-- Note: must come last to silence warnings due to AMP on GHC < 7.10+import Prelude hiding (mapM, mapM_, any, sequence, concat)+ debugPropagate :: Bool debugInvalidateHeight :: Bool@@ -109,6 +109,7 @@ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment]) , eventEnvHoldInits :: !(IORef [SomeHoldInit]) , eventEnvClears :: !(IORef [SomeMaybeIORef])+ , eventEnvRootClears :: !(IORef [SomeDMapIORef]) , eventEnvCurrentHeight :: !(IORef Int) , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo]) , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))@@ -138,6 +139,11 @@ clears <- asks eventEnvClears liftIO $ modifyIORef' clears (SomeMaybeIORef r :) +scheduleRootClear :: IORef (DMap k) -> EventM ()+scheduleRootClear r = EventM $ do+ clears <- asks eventEnvRootClears+ liftIO $ modifyIORef' clears (SomeDMapIORef r :)+ scheduleMerge :: Int -> MergeSubscribed a -> EventM () scheduleMerge height subscribed = EventM $ do delayedRef <- asks eventEnvDelayedMerges@@ -213,19 +219,19 @@ data RootSubscribed a = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])- , rootSubscribedOccurrence :: !(IORef (Maybe a)) -- Alias to rootOccurrence+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence } -data Root a- = Root { rootOccurrence :: !(IORef (Maybe a)) -- The currently-firing occurrence of this event- , rootSubscribed :: !(IORef (Maybe (RootSubscribed a)))- , rootInit :: !(RootTrigger a -> IO (IO ()))+data Root (k :: * -> *)+ = Root { rootOccurrence :: !(IORef (DMap k)) -- The currently-firing occurrence of this event+ , rootSubscribed :: !(IORef (DMap (WrapArg RootSubscribed k)))+ , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ())) } data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a) -- EventM can do everything BehaviorM can, plus create holds-newtype EventM a = EventM { unEventM :: ReaderT EventEnv IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over+newtype EventM a = EventM { unEventM :: ReaderT EventEnv IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over data PushSubscribed a b = PushSubscribed { pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are)@@ -365,7 +371,7 @@ SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner" data Event a- = EventRoot !(Root a)+ = 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)@@ -375,7 +381,7 @@ showEventType :: Event a -> String showEventType = \case- EventRoot _ -> "EventRoot"+ EventRoot _ _ -> "EventRoot" EventNever -> "EventNever" EventPush _ -> "EventPush" EventMerge _ -> "EventMerge"@@ -402,7 +408,7 @@ -- the weak pointer to it in some cases. {-# NOINLINE newRootSubscribed #-}-newRootSubscribed :: IORef (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)+newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a) newRootSubscribed occ subs = return $! RootSubscribed { rootSubscribedOccurrence = occ@@ -495,14 +501,14 @@ , coincidenceSubscribed = unsafeNewIORef a Nothing } -newRoot :: IO (Root a)+newRoot :: IO (Root k) newRoot = do- occRef <- newIORef Nothing- subscribedRef <- newIORef Nothing+ occRef <- newIORef DMap.empty+ subscribedRef <- newIORef DMap.empty return $ Root { rootOccurrence = occRef , rootSubscribed = subscribedRef- , rootInit = const $ return $ return ()+ , rootInit = \_ _ -> return $ return () } propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()@@ -517,10 +523,16 @@ run roots after = do when debugPropagate $ putStrLn "Running an event frame" result <- runFrame $ do- forM_ roots $ \(RootTrigger (_, occRef) :=> a) -> do- liftIO $ writeIORef occRef $ Just a- scheduleClear occRef- forM_ roots $ \(RootTrigger (subscribersRef, _) :=> a) -> do+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do+ occBefore <- liftIO $ do+ occBefore <- readIORef occRef+ writeIORef occRef $ DMap.insert k a occBefore+ return occBefore+ if DMap.null occBefore+ then do scheduleRootClear occRef+ return $ Just r+ else return Nothing+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> a) -> do propagateAndUpdateSubscribersRef subscribersRef a delayedRef <- EventM $ asks eventEnvDelayedMerges let go = do@@ -553,6 +565,8 @@ data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a)) +data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k))+ data SomeAssignment = forall a. SomeAssignment (Hold a) a data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)@@ -717,7 +731,7 @@ readEvent :: Event a -> ResultM (Maybe a) readEvent e = case e of- EventRoot r -> liftIO $ readIORef $ rootOccurrence r+ EventRoot k r -> liftIO $ liftM (DMap.lookup k) $ readIORef $ rootOccurrence r EventNever -> return Nothing EventPush p -> do subscribed <- getPushSubscribed p@@ -756,7 +770,7 @@ getEventSubscribed :: Event a -> EventM (EventSubscribed a) getEventSubscribed e = case e of- EventRoot r -> liftM EventSubscribedRoot $ getRootSubscribed r+ EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r EventNever -> return EventSubscribedNever EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f@@ -793,7 +807,7 @@ getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a) getEventSubscribedOcc es = case es of- EventSubscribedRoot r -> readIORef $ rootSubscribedOccurrence r+ EventSubscribedRoot r -> rootSubscribedOccurrence r EventSubscribedNever -> return Nothing EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed EventSubscribedFan k subscribed -> do@@ -824,21 +838,21 @@ noinlineFalse = False {-# NOINLINE noinlineFalse #-} -getRootSubscribed :: Root a -> EventM (RootSubscribed a)-getRootSubscribed r = do+getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)+getRootSubscribed k r = do mSubscribed <- liftIO $ readIORef $ rootSubscribed r- case mSubscribed of+ case DMap.lookup (WrapArg k) mSubscribed of Just subscribed -> return subscribed Nothing -> liftIO $ do subscribersRef <- newIORef []- subscribed <- newRootSubscribed (rootOccurrence r) subscribersRef+ subscribed <- newRootSubscribed (liftM (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 $ RootTrigger (subscribersRef, rootOccurrence r)+ 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 $ writeIORef (rootSubscribed r) $ Just subscribed+ liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert (WrapArg k) subscribed return subscribed -- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in@@ -1057,9 +1071,10 @@ holdInitRef <- newIORef [] heightRef <- newIORef 0 toClearRef <- newIORef []+ toClearRootRef <- newIORef [] coincidenceInfosRef <- newIORef [] delayedRef <- liftIO $ newIORef IntMap.empty- result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef heightRef coincidenceInfosRef delayedRef) $ do+ result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) $ do result <- a let runHoldInits = do holdInits <- liftIO $ readIORef holdInitRef@@ -1071,6 +1086,8 @@ return result toClear <- readIORef toClearRef forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing+ toClearRoot <- readIORef toClearRootRef+ forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty toAssign <- readIORef toAssignRef toReconnectRef <- newIORef [] forM_ toAssign $ \(SomeAssignment h v) -> do@@ -1323,16 +1340,22 @@ {-# INLINE hold #-} hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e) -newtype RootTrigger a = RootTrigger (IORef [WeakSubscriber a], IORef (Maybe a))+data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k), k a)+newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a } +instance R.MonadSubscribeEvent Spider SpiderHostFrame where+ subscribeEvent e = SpiderHostFrame $ do+ _ <- getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used+ return $ SpiderEventHandle (unSpiderEvent e)+ instance R.ReflexHost Spider where type EventTrigger Spider = RootTrigger- type EventHandle Spider = R.Event Spider+ type EventHandle Spider = SpiderEventHandle type HostFrame Spider = SpiderHostFrame -instance R.MonadReadEvent Spider ResultM where+instance R.MonadReadEvent Spider ReadPhase where {-# INLINE readEvent #-}- readEvent = liftM (fmap return) . readEvent . unSpiderEvent+ readEvent = ReadPhase . liftM (fmap return) . readEvent . unEventHandle instance MonadRef EventM where type Ref EventM = Ref IO@@ -1347,9 +1370,9 @@ {-# INLINE atomicModifyRef #-} atomicModifyRef r f = liftIO $ atomicModifyRef r f -newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)+newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) -newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)+newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) instance R.MonadSample Spider SpiderHostFrame where sample = SpiderHostFrame . R.sample --TODO: This can cause problems with laziness, so we should get rid of it if we can@@ -1358,29 +1381,44 @@ {-# INLINE hold #-} hold v0 e = SpiderHostFrame $ R.hold v0 e -newEventWithTriggerIO :: (RootTrigger a -> IO (IO ())) -> IO (R.Event Spider a)+newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a) newEventWithTriggerIO f = do- occRef <- newIORef Nothing- subscribedRef <- newIORef Nothing+ es <- newFanEventWithTriggerIO $ \Refl -> f+ return $ select es Refl++newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)+newFanEventWithTriggerIO f = do+ occRef <- newIORef DMap.empty+ subscribedRef <- newIORef DMap.empty let !r = Root { rootOccurrence = occRef , rootSubscribed = subscribedRef , rootInit = f }- return $ SpiderEvent $ EventRoot r+ return $ EventSelector $ \k -> EventRoot k r instance R.MonadReflexCreateTrigger Spider SpiderHost where- newEventWithTrigger = SpiderHost . newEventWithTriggerIO+ newEventWithTrigger = SpiderHost . liftM SpiderEvent . newEventWithTriggerIO+ newFanEventWithTrigger f = SpiderHost $ do+ es <- newFanEventWithTriggerIO f+ return $ R.EventSelector $ SpiderEvent . select es instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where- newEventWithTrigger = SpiderHostFrame . EventM . liftIO . newEventWithTriggerIO+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do+ es <- newFanEventWithTriggerIO f+ return $ R.EventSelector $ SpiderEvent . select es -instance R.MonadReflexHost Spider SpiderHost where- fireEventsAndRead es a = SpiderHost $ run es a+instance R.MonadSubscribeEvent Spider SpiderHost where subscribeEvent e = SpiderHost $ do _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used- return e- runFrame = SpiderHost . runFrame+ return $ SpiderEventHandle (unSpiderEvent e)++newtype ReadPhase a = ReadPhase { runReadPhase :: ResultM a } deriving (Functor, Applicative, Monad, MonadFix, R.MonadSample Spider, R.MonadHold Spider)++instance R.MonadReflexHost Spider SpiderHost where+ type ReadPhase SpiderHost = ReadPhase+ fireEventsAndRead es (ReadPhase a) = SpiderHost $ run es a runHostFrame = SpiderHost . runFrame . runSpiderHostFrame instance MonadRef SpiderHost where
+ test/Reflex/Pure.hs view
@@ -0,0 +1,46 @@+{- | This module provides a pure implementation of Reflex, which is intended to serve as a reference for the semantics of the Reflex class. All implementations of Reflex should produce the same results as this implementation, although performance and laziness/strictness may differ.+-}+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, EmptyDataDecls #-}+module Reflex.Pure where++import Reflex.Class+import Data.Functor.Misc++import Control.Monad+import Data.MemoTrie+import qualified Data.Dependent.Map as DMap++data Pure t++-- | The Enum instance of t must be dense: for all x :: t, there must not exist any y :: t such that pred x < y < x+-- The HasTrie instance will be used exclusively to memoize functions of t, not for any of its other capabilities+instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where+ newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }+ newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }+ type PushM (Pure t) = (->) t+ type PullM (Pure t) = (->) t+ never = Event $ \_ -> Nothing+ constant x = Behavior $ \_ -> x+ push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t+ pull = Behavior . memo+ merge events = Event $ memo $ \t ->+ let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events+ in if DMap.null currentOccurrences+ then Nothing+ else Just currentOccurrences+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k+ switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t+ coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t++instance Ord t => MonadSample (Pure t) ((->) t) where+ sample = unBehavior++instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where+ hold initialValue e initialTime = Behavior f+ where f = memo $ \sampleTime ->+ if sampleTime <= initialTime -- Really, the sampleTime should never be prior to the initialTime, because that would mean the Behavior is being sampled before being created+ then initialValue+ else let lastTime = pred sampleTime+ in case unEvent e lastTime of+ Nothing -> f lastTime+ Just x -> x
+ test/Reflex/Test/CrossImpl.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, BangPatterns, ConstraintKinds #-}+module Reflex.Test.CrossImpl (test) where++import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl, and)++import Reflex.Class+import Reflex.Host.Class+import Reflex.Dynamic+import qualified Reflex.Spider.Internal as S+import qualified Reflex.Pure as P+import Control.Monad.Ref++import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import qualified Data.Set as Set+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Control.Arrow (second, (&&&))+import Data.Traversable+import Data.Foldable+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Control.Monad.Writer hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Data.Dependent.Map (DSum (..))+import System.Mem+import System.Exit++import System.IO.Unsafe++mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a+mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of+ Nothing -> error $ "mapToPureBehavior: no value for time " <> show t+ Just (_, v) -> v++mapToPureEvent :: Map Int a -> Event PureReflexDomain a+mapToPureEvent m = P.Event $ flip Map.lookup m++relevantTestingTimes :: (Map Int a, Map Int b) -> [Int]+relevantTestingTimes (b, e) = case Set.minView &&& Set.maxView $ Map.keysSet b `Set.union` Map.keysSet e of+ (Just (t0, _), Just (t1, _)) -> [t0..t1+1] -- We need to go to b+1 to see the result of the final event+ _ -> [] -- Doesn't actually make much sense++type PureReflexDomain = P.Pure Int+type TimeM = (->) Int++testPure :: (t ~ PureReflexDomain, m ~ TimeM) => ((Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)+testPure builder (b, e) =+ let (P.Behavior b', P.Event e') = ($ 0) $ builder (mapToPureBehavior b, mapToPureEvent e)+ relevantTimes = relevantTestingTimes (b, e)+ e'' = Map.mapMaybe id $ Map.fromList $ map (id &&& e') relevantTimes+ b'' = Map.fromList $ map (id &&& b') relevantTimes+ in (b'', e'')++class MapMSignals a a' t t' | a -> t, a' -> t', a t' -> a', a' t -> a where+ mapMSignals :: Monad m => (forall b. Behavior t b -> m (Behavior t' b)) -> (forall b. Event t b -> m (Event t' b)) -> a -> m a'++instance MapMSignals (Behavior t a) (Behavior t' a) t t' where+ mapMSignals fb _ = fb++instance MapMSignals (Event t a) (Event t' a) t t' where+ mapMSignals _ fe = fe++instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where+ mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)++testSpider :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do+ (re, reTrigger) <- newEventWithTriggerRef+ (rb, rbTrigger) <- newEventWithTriggerRef+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb+ (b', e') <- runHostFrame $ builder (b, re)+ e'Handle <- subscribeEvent e' --TODO: This should be unnecessary+ 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+ 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]+ Nothing -> []+ fireEventsAndRead firing $ sequence =<< readEvent e'Handle+ liftIO performGC+ return (t, (bOutput, eOutput))+ return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs) ++tracePerf :: Show a => a -> b -> b+tracePerf = flip const++testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> IO Bool+testAgreement builder inputs = do+ let identityResult = testPure builder inputs+ tracePerf "---------" $ return ()+ let spiderResult = testSpider builder inputs+ tracePerf "---------" $ return ()+ let resultsAgree = identityResult == spiderResult+ if resultsAgree+ then do putStrLn "Success:"+ print identityResult+ else do putStrLn "Failure:"+ putStrLn $ "Pure result: " <> show identityResult+ putStrLn $ "Spider result: " <> show spiderResult+ return resultsAgree++type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))++data TestCase = forall a b c d. (Eq c, Eq d, Show c, Show d) => TestCase (Map Int a, Map Int b) (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))++testCases :: [(String, TestCase)]+testCases =+ [ (,) "hold" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do+ b' <- hold "123" e+ return (b', e)+ , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do+ e' <- liftM updated $ count e+ b' <- hold (0 :: Int) e'+ return (b', e')+ , (,) "onceE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ e' <- onceE $ leftmost [e, e]+ return (b, e')+ , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = fmap (const e) e+ b' <- hold never e'+ let e'' = switch b'+ return (b, e'')+ , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = flip pushAlways e $ const $ do+ let ea = fmap (const "a") e+ let eb = fmap (const "b") e+ let eab = leftmost [ea, eb]+ liftM switch $ hold eab never+ e'' = coincidence e'+ return (b, e'')+ , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = flip pushAlways e $ const $ do+ let ea = fmap (const "a") e+ let eb = fmap (const "b") e+ let eab = leftmost [ea, eb]+ liftM switch $ hold eab (fmap (const e) e)+ e'' = coincidence e'+ return (b, e'')+ , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = leftmost [e, e]+ e'' <- liftM switch $ hold e' (fmap (const e) e)+ return (b, e'')+ , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = fmap (const e) e+ e'' <- switchPromptly never e'+ return (b, e'')+ , (,) "switchPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = fmap (const e) e+ e'' <- switchPromptly never $ leftmost [e', e']+ return (b, e'')+ , (,) "switchPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = leftmost [e, e]+ e'' <- switchPromptly never (fmap (const e) e')+ return (b, e'')+ , (,) "switchPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do+ let e' = leftmost [e, e]+ e'' <- switchPromptly never (fmap (const e') e)+ return (b, e'')+ , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = leftmost [e, e]+ e'' <- liftM switch $ hold never (fmap (const e') e)+ return (b, e'')+ , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = flip push e $ \_ -> do+ return . Just =<< onceE e+ e'' <- switchPromptly never e'+ return (b, e'')+ , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = flip pushAlways e $ \_ -> do+ switchPromptly e never+ e'' <- switchPromptly never e'+ return (b, e'')+ , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = flip pushAlways e $ \_ -> return $ fmap id e+ e'' = coincidence e'+ return (b, e'')+ , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = flip pushAlways e $ \_ -> return $ leftmost [e, e]+ e'' = coincidence e'+ return (b, e'')+ , (,) "coincidence-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ let e' = flip pushAlways e $ \_ -> return $ coincidence $ fmap (const e) e+ e'' = coincidence e'+ return (b, e'')+ , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do+ let e' = flip pushAlways e $ \_ -> onceE e+ e'' = coincidence e'+ return (b, e'')+ , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do+ let eChild = flip pushAlways e $ const $ do+ let eNewValues = leftmost [e, e]+ return $ coincidence $ fmap (const eNewValues) eNewValues+ e' = coincidence eChild+ return (b, e')+ , (,) "coincidence-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do+ let eChild = flip pushAlways e $ const $ do+ let e' = coincidence $ fmap (const e) e+ return $ leftmost [e', e']+ e'' = coincidence eChild+ return (b, e'')+ , (,) "coincidence-7" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do+ let e' = leftmost [e, e]+ eCoincidences = coincidence $ fmap (const e') e+ return (b, eCoincidences)+ , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ eo <- onceE e+ bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo+ let b' = pull $ sample =<< sample bb+ return (b', e)+ , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do+ bb <- hold "b" e+ bd <- hold never . fmap (const e) =<< onceE e+ eOuter <- liftM (pushAlways sample . fmap (const bb)) $ onceE e+ let eInner = switch bd+ e' = leftmost [eOuter, eInner]+ return (b, e')+ ]++test :: IO ()+test = do+ results <- forM testCases $ \(name, TestCase inputs builder) -> do+ putStrLn $ "Test: " <> name+ testAgreement builder inputs+ exitWith $ if and results+ then ExitSuccess+ else ExitFailure 1