git.iko.soy/reflex
on develop help sign in
Merge branch 'develop'

# Conflicts: # default.nix

commite7e40d0449b27299e0ff70157ab47115f7ab6b51 authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 31 Jul 2015, 21:30 (11 years ago) parent638da82a9add3d
11 files changed+680−102
compare with develop
unifiedsplit
.ghci+1−1 .travis.yml+24 default.nix+6−3 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 test/Reflex/Test/CrossImpl.hs+228
.ghci+1−1
@@ -1,4 +1,4 @@
11:set -isrc
22:set -hide-package MonadCatchIO-mtl
33:set -hide-package monads-fd
4−:set -XOverloadedStrings
4+:seti -XOverloadedStrings
.travis.ymlnew file+24
@@ -0,0 +1,24 @@
1+sudo: false
2+before_install:
3+ - travis_retry cabal-$CABALVER update
4+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/happy/1.19.5/bin:/opt/alex/3.1.4/bin:$PATH
5+install:
6+ - travis_retry cabal-$CABALVER install --only-dependencies -j --enable-tests
7+script:
8+ - cabal-$CABALVER configure -v2 --enable-tests
9+ - cabal-$CABALVER build
10+ - cabal-$CABALVER test
11+ - cabal-$CABALVER sdist # tests that a source-distribution can be generated
12+# Check that the resulting source distribution can be built & installed.
13+# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
14+# `cabal install --force-reinstalls dist/*-*.tar.gz`
15+ - SRC_TGZ=$(cabal-$CABALVER info . | awk '{print $2;exit}').tar.gz &&
16+ (cd dist && cabal-$CABALVER install --force-reinstalls "$SRC_TGZ")
17+
18+matrix:
19+ include:
20+ - env: CABALVER=1.18 GHCVER=7.8.4
21+ addons: {apt: {packages: [cabal-install-1.18, ghc-7.8.4, alex-3.1.4, happy-1.19.5], sources: [hvr-ghc]}}
22+ - env: CABALVER=1.22 GHCVER=7.10.1
23+ addons: {apt: {packages: [cabal-install-1.22, ghc-7.10.1, alex-3.1.4, happy-1.19.5],sources: [hvr-ghc]}}
24+ fast_finish: true
default.nix+6−3
@@ -1,12 +1,15 @@
11{ mkDerivation, dependent-map, dependent-sum
2−, mtl, ref-tf, semigroups, these
2+, mtl, ref-tf, semigroups, these, MemoTrie, exception-transformers
33}:
44mkDerivation {
55 pname = "reflex";
6− version = "0.2";
6+ version = "0.3";
77 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
88 buildDepends = [
9− dependent-map dependent-sum mtl ref-tf semigroups these
9+ dependent-map dependent-sum mtl ref-tf semigroups these exception-transformers
10+ ];
11+ testDepends = [
12+ MemoTrie
1013 ];
1114 license = null;
1215}
reflex.cabal+22−4
@@ -1,5 +1,5 @@
11Name: reflex
2−Version: 0.2
2+Version: 0.3
33Synopsis: Higher-order Functional Reactive Programming
44Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
55License: BSD3
@@ -23,9 +23,12 @@ library
2323 mtl >= 2.1 && < 2.3,
2424 containers == 0.5.*,
2525 these == 0.4.*,
26− primitive == 0.5.*,
26+ primitive >= 0.5 && < 0.7,
2727 template-haskell >= 2.9 && < 2.11,
28− ref-tf == 0.4.*
28+ ref-tf == 0.4.*,
29+ exception-transformers == 0.4.*,
30+ transformers >= 0.2,
31+ transformers-compat >= 0.3
2932
3033 exposed-modules:
3134 Reflex,
@@ -38,9 +41,24 @@ library
3841 Data.Functor.Misc
3942
4043 other-extensions: TemplateHaskell
41− ghc-prof-options: -fprof-auto
4244 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
4345
46+test-suite cross-impl
47+ type: exitcode-stdio-1.0
48+ main-is: Reflex/Test/CrossImpl.hs
49+ other-modules:
50+ Reflex.Pure
51+ ghc-options: -O2 -main-is Reflex.Test.CrossImpl.test
52+ hs-source-dirs: test
53+ build-depends:
54+ base,
55+ reflex,
56+ ref-tf,
57+ mtl,
58+ containers,
59+ dependent-map,
60+ MemoTrie == 0.6.*
61+
4462benchmark spider-bench
4563 type: exitcode-stdio-1.0
4664 hs-source-dirs: bench
src/Data/Functor/Misc.hs+6−2
@@ -1,4 +1,4 @@
1−{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables #-}
1+{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, PolyKinds #-}
22module Data.Functor.Misc where
33
44import Data.GADT.Compare
@@ -8,8 +8,9 @@ import Data.Dependent.Map (DMap, DSum (..))
88import qualified Data.Dependent.Map as DMap
99import Data.Typeable hiding (Refl)
1010import Data.These
11+import Data.Maybe
1112
12−data WrapArg :: (* -> *) -> (* -> *) -> * -> * where
13+data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
1314 WrapArg :: f a -> WrapArg g f (g a)
1415
1516instance GEq f => GEq (WrapArg g f) where
@@ -61,6 +62,9 @@ rewrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> WrapArg k :
6162unwrapDMap :: (forall a. f a -> a) -> DMap (WrapArg f k) -> DMap k
6263unwrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> k :=> f v) . DMap.toAscList
6364
65+unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap (WrapArg f k) -> DMap k
66+unwrapDMapMaybe f = DMap.fromDistinctAscList . catMaybes . map (\(WrapArg k :=> v) -> fmap (k :=>) $ f v) . DMap.toAscList
67+
6468mapToDMap :: Map k v -> DMap (Const2 k v)
6569mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
6670
src/Reflex/Class.hs+72−7
@@ -1,11 +1,14 @@
11{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase #-}
22module Reflex.Class where
33
4−import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
5−
4+import Control.Applicative
65import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
76import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
87import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
8+import Control.Monad.Trans.Writer (WriterT())
9+import Control.Monad.Trans.Except (ExceptT())
10+import Control.Monad.Trans.Cont (ContT())
11+import Control.Monad.Trans.RWS (RWST())
912import Data.List.NonEmpty (NonEmpty (..))
1013import Data.These
1114import Data.Align
@@ -17,10 +20,14 @@ import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))
1720import qualified Data.Dependent.Map as DMap
1821import Data.Functor.Misc
1922import Data.Semigroup
23+import Data.Traversable
24+
25+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
26+import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
2027
2128import Debug.Trace (trace)
2229
23−class (MonadHold t (PushM t), MonadSample t (PullM t), Functor (Event t), Functor (Behavior t)) => Reflex t where
30+class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Functor (Event t), Functor (Behavior t)) => Reflex t where
2431 -- | 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
2532 data Behavior t :: * -> *
2633 -- | 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 @@ class (MonadHold t (PushM t), MonadSample t (PullM t), Functor (Event t), Functo
3946 type PullM t :: * -> *
4047 -- | 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
4148 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
42− -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events
49+ -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events
4350 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
4451 -- | Create an Event that will occur whenever the currently-selected input Event occurs
4552 switch :: Behavior t (Event t a) -> Event t a
4653 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring
4754 coincidence :: Event t (Event t a) -> Event t a
4855
49−class Monad m => MonadSample t m | m -> t where
56+class (Applicative m, Monad m) => MonadSample t m | m -> t where
5057 -- | Get the current value in the Behavior
5158 sample :: Behavior t a -> m a
5259
@@ -66,6 +73,36 @@ instance MonadSample t m => MonadSample t (ReaderT r m) where
6673instance MonadHold t m => MonadHold t (ReaderT r m) where
6774 hold a0 = lift . hold a0
6875
76+instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
77+ sample = lift . sample
78+
79+instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
80+ hold a0 = lift . hold a0
81+
82+instance MonadSample t m => MonadSample t (StateT s m) where
83+ sample = lift . sample
84+
85+instance MonadHold t m => MonadHold t (StateT s m) where
86+ hold a0 = lift . hold a0
87+
88+instance MonadSample t m => MonadSample t (ExceptT e m) where
89+ sample = lift . sample
90+
91+instance MonadHold t m => MonadHold t (ExceptT e m) where
92+ hold a0 = lift . hold a0
93+
94+instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
95+ sample = lift . sample
96+
97+instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
98+ hold a0 = lift . hold a0
99+
100+instance MonadSample t m => MonadSample t (ContT r m) where
101+ sample = lift . sample
102+
103+instance MonadHold t m => MonadHold t (ContT r m) where
104+ hold a0 = lift . hold a0
105+
69106--------------------------------------------------------------------------------
70107-- Convenience functions
71108--------------------------------------------------------------------------------
@@ -73,7 +110,7 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where
73110-- | Create an Event from another Event.
74111-- The provided function can sample 'Behavior's and hold 'Event's.
75112pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
76−pushAlways f e = push (liftM Just . f) e
113+pushAlways f = push (liftM Just . f)
77114
78115-- | Flipped version of 'fmap'.
79116ffor :: Functor f => f a -> (a -> b) -> f b
@@ -82,6 +119,28 @@ ffor = flip fmap
82119instance Reflex t => Functor (Behavior t) where
83120 fmap f = pull . liftM f . sample
84121
122+instance Reflex t => Applicative (Behavior t) where
123+ pure = constant
124+ f <*> x = pull $ sample f `ap` sample x
125+ _ *> b = b
126+ a <* _ = a
127+
128+instance Reflex t => Monad (Behavior t) where
129+ a >>= f = pull $ sample a >>= sample . f
130+ -- 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.
131+ return = constant
132+ fail = error "Monad (Behavior t) does not support fail"
133+
134+instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
135+ a <> b = pull $ liftM2 (<>) (sample a) (sample b)
136+ sconcat = pull . liftM sconcat . mapM sample
137+ times1p n = fmap $ times1p n
138+
139+instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
140+ mempty = constant mempty
141+ mappend a b = pull $ liftM2 mappend (sample a) (sample b)
142+ mconcat = pull . liftM mconcat . mapM sample
143+
85144--TODO: See if there's a better class in the standard libraries already
86145-- | A class for values that combines filtering and mapping using 'Maybe'.
87146class FunctorMaybe f where
@@ -239,7 +298,7 @@ dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
239298-- 'Event's occurs. If both occur at the same time they are combined
240299-- using 'mappend'.
241300appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
242−appendEvents e1 e2 = fmap (mergeThese mappend) $ align e1 e2
301+appendEvents e1 e2 = mergeThese mappend <$> align e1 e2
243302
244303{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
245304sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
@@ -299,3 +358,9 @@ instance Reflex t => Align (Event t) where
299358-- occurs and the 'Behavior' is true at the time of occurence.
300359gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
301360gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
361+
362+-- | Create a new behavior given a starting behavior and switch to a the
363+-- behvior carried by the event when it fires.
364+switcher :: (Reflex t, MonadHold t m)
365+ => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
366+switcher b eb = pull . (sample <=< sample) <$> hold b eb
src/Reflex/Dynamic.hs+36−12
@@ -156,16 +156,22 @@ mapDynM f d = do
156156-- time the 'Event' occurs using a folding function on the previous
157157-- value and the value of the 'Event'.
158158foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
159−foldDyn f = foldDynM (\o v -> return $ f o v)
159+foldDyn f = foldDynMaybe $ \o v -> Just $ f o v
160160
161161-- | Create a 'Dynamic' using the initial value and change it each
162162-- time the 'Event' occurs using a monadic folding function on the
163163-- previous value and the value of the 'Event'.
164164foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
165−foldDynM f z e = do
165+foldDynM f = foldDynMaybeM $ \o v -> liftM Just $ f o v
166+
167+foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
168+foldDynMaybe f = foldDynMaybeM $ \o v -> return $ f o v
169+
170+foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
171+foldDynMaybeM f z e = do
166172 rec let e' = flip push e $ \o -> do
167173 v <- sample b'
168− liftM Just $ f o v
174+ f o v
169175 b' <- hold z e'
170176 return $ Dynamic b' e'
171177
@@ -421,12 +427,20 @@ class RebuildSortedHList l where
421427 rebuildSortedHList :: [DSum (HListPtr l)] -> HList l
422428
423429instance RebuildSortedHList '[] where
424− rebuildSortedFHList [] = FHNil
425− rebuildSortedHList [] = HNil
430+ rebuildSortedFHList l = case l of
431+ [] -> FHNil
432+ _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"
433+ rebuildSortedHList l = case l of
434+ [] -> HNil
435+ _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"
426436
427437instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
428− rebuildSortedFHList ((WrapArg HHeadPtr :=> h) : t) = FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t
429− rebuildSortedHList ((HHeadPtr :=> h) : t) = HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t
438+ rebuildSortedFHList l = case l of
439+ ((WrapArg HHeadPtr :=> h) : t) -> FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t
440+ _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
441+ rebuildSortedHList l = case l of
442+ ((HHeadPtr :=> h) : t) -> HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t
443+ _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
430444
431445dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l
432446dmapToHList = rebuildSortedHList . DMap.toList
@@ -449,12 +463,16 @@ class AllAreFunctors (f :: a -> *) (l :: [a]) where
449463
450464instance AllAreFunctors f '[] where
451465 type FunctorList f '[] = '[]
452− toFHList HNil = FHNil
466+ toFHList l = case l of
467+ HNil -> FHNil
468+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
453469 fromFHList FHNil = HNil
454470
455471instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
456472 type FunctorList f (h ': t) = f h ': FunctorList f t
457− toFHList (a `HCons` b) = a `FHCons` toFHList b
473+ toFHList l = case l of
474+ a `HCons` b -> a `FHCons` toFHList b
475+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
458476 fromFHList (a `FHCons` b) = a `HCons` fromFHList b
459477
460478collectDyn :: ( RebuildSortedHList (HListElems b)
@@ -475,14 +493,20 @@ class IsHList a where
475493instance IsHList (a, b) where
476494 type HListElems (a, b) = [a, b]
477495 toHList (a, b) = hBuild a b
478− fromHList (a `HCons` b `HCons` HNil) = (a, b)
496+ fromHList l = case l of
497+ a `HCons` b `HCons` HNil -> (a, b)
498+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
479499
480500instance IsHList (a, b, c, d) where
481501 type HListElems (a, b, c, d) = [a, b, c, d]
482502 toHList (a, b, c, d) = hBuild a b c d
483− fromHList (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a, b, c, d)
503+ fromHList l = case l of
504+ a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
505+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
484506
485507instance IsHList (a, b, c, d, e, f) where
486508 type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
487509 toHList (a, b, c, d, e, f) = hBuild a b c d e f
488− fromHList (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a, b, c, d, e, f)
510+ fromHList l = case l of
511+ a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
512+ _ -> 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+152−24
@@ -1,44 +1,109 @@
1−{-# LANGUAGE ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, FunctionalDependencies #-}
1+{-# LANGUAGE ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, FunctionalDependencies, FlexibleContexts #-}
22module Reflex.Host.Class where
33
4−import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
5−
64import Reflex.Class
75
8−import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
9−import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
6+import Control.Applicative
7+import Control.Monad.Fix
8+import Control.Monad.Trans
9+import Control.Monad.Trans.Reader (ReaderT())
10+import Control.Monad.Trans.Writer (WriterT())
11+import Control.Monad.Trans.Cont (ContT())
12+import Control.Monad.Trans.Except (ExceptT())
13+import Control.Monad.Trans.RWS (RWST())
14+import Control.Monad.Trans.State (StateT())
1015import Data.Dependent.Sum (DSum)
16+import Data.Monoid
17+import Data.GADT.Compare
1118import Control.Monad.Ref
1219
13−class Reflex t => ReflexHost t where
20+-- Note: this import must come last to silence warnings from AMP
21+import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
22+
23+-- | Framework implementation support class for the reflex implementation represented by @t@.
24+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
1425 type EventTrigger t :: * -> *
1526 type EventHandle t :: * -> *
1627 type HostFrame t :: * -> *
1728
18−class (ReflexHost t, Monad m) => MonadReadEvent t m | m -> t where
29+-- | 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
30+class (Reflex t, Monad m) => MonadSubscribeEvent t m | m -> t where
31+ -- | Subscribe to an event and set it up if needed.
32+ --
33+ -- This function will create a new 'EventHandle' from an 'Event'. This handle may then be used via
34+ -- 'readEvent' in the read callback of 'fireEventsAndRead'.
35+ --
36+ -- If the event wasn't subscribed to before (either manually or through a dependent event or behavior)
37+ -- then this function will cause the event and all dependencies of this event to be set up.
38+ -- For example, if the event was created by 'newEventWithTrigger', then it's callback will be executed.
39+ --
40+ -- It's safe to call this function multiple times.
41+ subscribeEvent :: Event t a -> m (EventHandle t a)
42+
43+-- | Monad that allows to read events' values.
44+class (ReflexHost t, Applicative m, Monad m) => MonadReadEvent t m | m -> t where
45+ -- | Read the value of an 'Event' from an 'EventHandle' (created by calling 'subscribeEvent').
46+ --
47+ -- After event propagation is done, all events can be in two states: either they are firing with some value or they are not firing.
48+ -- In the former case, this function returns @Just act@, where @act@ in an action to read the current value of
49+ -- the event. In the latter case, the function returns @Nothing@.
50+ --
51+ -- This function is normally used in the calllback for 'fireEventsAndRead'.
1952 readEvent :: EventHandle t a -> m (Maybe (m a))
2053
21−class (Monad m, ReflexHost t) => MonadReflexCreateTrigger t m | m -> t where
22− -- | Creates an original Event (one that is not based on any other event).
54+-- | A monad where new events feed from external sources can be created.
55+class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where
56+ -- | Creates a root 'Event' (one that is not based on any other event).
57+ --
2358 -- When a subscriber first subscribes to an event (building another event
24− -- that depends on the subscription) the given callback function is run by
25− -- passing a trigger. The event is then set up in IO. The callback
26− -- function returns an accompanying teardown action.
59+ -- that depends on the subscription) the given callback function is run and
60+ -- passed a trigger. The callback function can then set up the event source in IO.
61+ -- After this is done, the callback function must return an accompanying teardown action.
62+ --
2763 -- Any time between setup and teardown the trigger can be used to fire
28− -- the event.
64+ -- the event, by passing it to 'fireEventsAndRead'.
65+ --
66+ -- 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.
2967 newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)
68+ newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k)
69+
70+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
71+ type ReadPhase m :: * -> *
72+ -- | Propagate some events firings and read the values of events afterwards.
73+ --
74+ -- This function will create a new frame to fire the given events. It will then update all
75+ -- dependent events and behaviors. After that is done, the given callback is executed which
76+ -- allows to read the final values of events and check whether they have fired in this frame or
77+ -- not.
78+ --
79+ -- All events that are given are fired at the same time.
80+ --
81+ -- This function is typically used in the main loop of a reflex framework implementation.
82+ -- The main loop waits for external events to happen (such as keyboard input or a mouse click)
83+ -- and then fires the corresponding events using this function. The read callback can be used
84+ -- to read output events and perform a corresponding response action to the external event.
85+ fireEventsAndRead :: [DSum (EventTrigger t)] -> (ReadPhase m a) -> m a
3086
31−class (Monad m, ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexHost t m | m -> t where
32− fireEventsAndRead :: [DSum (EventTrigger t)] -> (forall m'. (MonadReadEvent t m') => m' a) -> m a
33− subscribeEvent :: Event t a -> m (EventHandle t a) --TODO: Return a handle, and use them in fireEventsAnRead
34− runFrame :: PushM t a -> m a
87+ -- | Run a frame without any events firing.
88+ --
89+ -- This function should be used when you want to use 'sample' and 'hold' when no events are currently firing.
90+ -- Using this function in that case can improve performance, since the implementation can assume that no events
91+ -- are firing when 'sample' or 'hold' are called.
92+ --
93+ -- This function is commonly used to set up the basic event network when the application starts up.
3594 runHostFrame :: HostFrame t a -> m a
3695
96+-- | Like 'fireEventsAndRead', but without reading any events.
3797fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t)] -> m ()
38−{-# INLINE fireEvents #-}
3998fireEvents dm = fireEventsAndRead dm $ return ()
99+{-# INLINE fireEvents #-}
40100
41−{-# INLINE newEventWithTriggerRef #-}
101+-- | Create a new event and store its trigger in an 'IORef' while it's active.
102+--
103+-- 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).
104+-- This function returns an Event and an 'IORef'. As long as the event is active, the 'IORef' will contain 'Just' the event trigger to
105+-- trigger this event. When the event is not active, the 'IORef' will contain 'Nothing'. This allows event sources to be more efficient,
106+-- since they don't need to produce events when nobody is listening.
42107newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a)))
43108newEventWithTriggerRef = do
44109 rt <- newRef Nothing
@@ -46,17 +111,80 @@ newEventWithTriggerRef = do
46111 writeRef rt $ Just t
47112 return $ writeRef rt Nothing
48113 return (e, rt)
114+{-# INLINE newEventWithTriggerRef #-}
49115
50116--------------------------------------------------------------------------------
51117-- Instances
52118--------------------------------------------------------------------------------
53119
54−instance (Reflex t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (ReaderT r m) where
55− newEventWithTrigger initializer = do
56− lift $ newEventWithTrigger initializer
120+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ReaderT r m) where
121+ newEventWithTrigger = lift . newEventWithTrigger
122+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
57123
58−instance (Reflex t, MonadReflexHost t m) => MonadReflexHost t (ReaderT r m) where
124+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ReaderT r m) where
125+ subscribeEvent = lift . subscribeEvent
126+
127+instance MonadReflexHost t m => MonadReflexHost t (ReaderT r m) where
128+ type ReadPhase (ReaderT r m) = ReadPhase m
129+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
130+ runHostFrame = lift . runHostFrame
131+
132+instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (WriterT w m) where
133+ newEventWithTrigger = lift . newEventWithTrigger
134+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
135+
136+instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (WriterT w m) where
137+ subscribeEvent = lift . subscribeEvent
138+
139+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (WriterT w m) where
140+ type ReadPhase (WriterT w m) = ReadPhase m
59141 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
142+ runHostFrame = lift . runHostFrame
143+
144+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StateT s m) where
145+ newEventWithTrigger = lift . newEventWithTrigger
146+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
147+
148+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (StateT r m) where
60149 subscribeEvent = lift . subscribeEvent
61− runFrame = lift . runFrame
150+
151+instance MonadReflexHost t m => MonadReflexHost t (StateT s m) where
152+ type ReadPhase (StateT s m) = ReadPhase m
153+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
154+ runHostFrame = lift . runHostFrame
155+
156+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ContT r m) where
157+ newEventWithTrigger = lift . newEventWithTrigger
158+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
159+
160+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ContT r m) where
161+ subscribeEvent = lift . subscribeEvent
162+
163+instance MonadReflexHost t m => MonadReflexHost t (ContT r m) where
164+ type ReadPhase (ContT r m) = ReadPhase m
165+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
166+ runHostFrame = lift . runHostFrame
167+
168+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ExceptT e m) where
169+ newEventWithTrigger = lift . newEventWithTrigger
170+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
171+
172+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ExceptT r m) where
173+ subscribeEvent = lift . subscribeEvent
174+
175+instance MonadReflexHost t m => MonadReflexHost t (ExceptT e m) where
176+ type ReadPhase (ExceptT e m) = ReadPhase m
177+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
178+ runHostFrame = lift . runHostFrame
179+
180+instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (RWST r w s m) where
181+ newEventWithTrigger = lift . newEventWithTrigger
182+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
183+
184+instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (RWST r w s m) where
185+ subscribeEvent = lift . subscribeEvent
186+
187+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (RWST r w s m) where
188+ type ReadPhase (RWST r w s m) = ReadPhase m
189+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
62190 runHostFrame = lift . runHostFrame
src/Reflex/Spider/Internal.hs+87−49
@@ -1,8 +1,6 @@
1−{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase #-}
1+{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators #-}
22module Reflex.Spider.Internal where
33
4−import Prelude hiding (mapM, mapM_, any, sequence, concat)
5−
64import qualified Reflex.Class as R
75import qualified Reflex.Host.Class as R
86
@@ -13,9 +11,7 @@ import Data.Traversable
1311import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
1412import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
1513import GHC.Exts
16−#if !MIN_VERSION_base(4,8,0)
17−import Control.Applicative
18−#endif
14+import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2
1915import Data.Dependent.Map (DMap, DSum (..))
2016import qualified Data.Dependent.Map as DMap
2117import Data.GADT.Compare
@@ -24,12 +20,16 @@ import Data.Maybe
2420import Data.IntMap (IntMap)
2521import qualified Data.IntMap as IntMap
2622import Control.Monad.Ref
23+import Control.Monad.Exception
2724import Data.Monoid ((<>))
2825
2926import System.IO.Unsafe
3027import Unsafe.Coerce
3128import Control.Monad.Primitive
3229
30+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
31+import Prelude hiding (mapM, mapM_, any, sequence, concat)
32+
3333debugPropagate :: Bool
3434
3535debugInvalidateHeight :: Bool
@@ -109,6 +109,7 @@ data EventEnv
109109 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment])
110110 , eventEnvHoldInits :: !(IORef [SomeHoldInit])
111111 , eventEnvClears :: !(IORef [SomeMaybeIORef])
112+ , eventEnvRootClears :: !(IORef [SomeDMapIORef])
112113 , eventEnvCurrentHeight :: !(IORef Int)
113114 , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])
114115 , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))
@@ -138,6 +139,11 @@ scheduleClear r = EventM $ do
138139 clears <- asks eventEnvClears
139140 liftIO $ modifyIORef' clears (SomeMaybeIORef r :)
140141
142+scheduleRootClear :: IORef (DMap k) -> EventM ()
143+scheduleRootClear r = EventM $ do
144+ clears <- asks eventEnvRootClears
145+ liftIO $ modifyIORef' clears (SomeDMapIORef r :)
146+
141147scheduleMerge :: Int -> MergeSubscribed a -> EventM ()
142148scheduleMerge height subscribed = EventM $ do
143149 delayedRef <- asks eventEnvDelayedMerges
@@ -213,19 +219,19 @@ data Invalidator
213219
214220data RootSubscribed a
215221 = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])
216− , rootSubscribedOccurrence :: !(IORef (Maybe a)) -- Alias to rootOccurrence
222+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
217223 }
218224
219−data Root a
220− = Root { rootOccurrence :: !(IORef (Maybe a)) -- The currently-firing occurrence of this event
221− , rootSubscribed :: !(IORef (Maybe (RootSubscribed a)))
222− , rootInit :: !(RootTrigger a -> IO (IO ()))
225+data Root (k :: * -> *)
226+ = Root { rootOccurrence :: !(IORef (DMap k)) -- The currently-firing occurrence of this event
227+ , rootSubscribed :: !(IORef (DMap (WrapArg RootSubscribed k)))
228+ , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
223229 }
224230
225231data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)
226232
227233-- EventM can do everything BehaviorM can, plus create holds
228−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
234+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
229235
230236data PushSubscribed a b
231237 = 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 @@ showSubscriberType = \case
365371 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
366372
367373data Event a
368− = EventRoot !(Root a)
374+ = forall k. GCompare k => EventRoot !(k a) !(Root k)
369375 | EventNever
370376 | forall b. EventPush !(Push b a)
371377 | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)
@@ -375,7 +381,7 @@ data Event a
375381
376382showEventType :: Event a -> String
377383showEventType = \case
378− EventRoot _ -> "EventRoot"
384+ EventRoot _ _ -> "EventRoot"
379385 EventNever -> "EventNever"
380386 EventPush _ -> "EventPush"
381387 EventMerge _ -> "EventMerge"
@@ -402,7 +408,7 @@ data EventSubscribed a
402408-- the weak pointer to it in some cases.
403409
404410{-# NOINLINE newRootSubscribed #-}
405−newRootSubscribed :: IORef (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)
411+newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)
406412newRootSubscribed occ subs =
407413 return $! RootSubscribed
408414 { rootSubscribedOccurrence = occ
@@ -495,14 +501,14 @@ coincidence a = EventCoincidence $ Coincidence
495501 , coincidenceSubscribed = unsafeNewIORef a Nothing
496502 }
497503
498−newRoot :: IO (Root a)
504+newRoot :: IO (Root k)
499505newRoot = do
500− occRef <- newIORef Nothing
501− subscribedRef <- newIORef Nothing
506+ occRef <- newIORef DMap.empty
507+ subscribedRef <- newIORef DMap.empty
502508 return $ Root
503509 { rootOccurrence = occRef
504510 , rootSubscribed = subscribedRef
505− , rootInit = const $ return $ return ()
511+ , rootInit = \_ _ -> return $ return ()
506512 }
507513
508514propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()
@@ -517,10 +523,16 @@ run :: [DSum RootTrigger] -> ResultM b -> IO b
517523run roots after = do
518524 when debugPropagate $ putStrLn "Running an event frame"
519525 result <- runFrame $ do
520− forM_ roots $ \(RootTrigger (_, occRef) :=> a) -> do
521− liftIO $ writeIORef occRef $ Just a
522− scheduleClear occRef
523− forM_ roots $ \(RootTrigger (subscribersRef, _) :=> a) -> do
526+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
527+ occBefore <- liftIO $ do
528+ occBefore <- readIORef occRef
529+ writeIORef occRef $ DMap.insert k a occBefore
530+ return occBefore
531+ if DMap.null occBefore
532+ then do scheduleRootClear occRef
533+ return $ Just r
534+ else return Nothing
535+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> a) -> do
524536 propagateAndUpdateSubscribersRef subscribersRef a
525537 delayedRef <- EventM $ asks eventEnvDelayedMerges
526538 let go = do
@@ -553,6 +565,8 @@ run roots after = do
553565
554566data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))
555567
568+data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k))
569+
556570data SomeAssignment = forall a. SomeAssignment (Hold a) a
557571
558572data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
@@ -717,7 +731,7 @@ readBehaviorTracked b = case b of
717731
718732readEvent :: Event a -> ResultM (Maybe a)
719733readEvent e = case e of
720− EventRoot r -> liftIO $ readIORef $ rootOccurrence r
734+ EventRoot k r -> liftIO $ liftM (DMap.lookup k) $ readIORef $ rootOccurrence r
721735 EventNever -> return Nothing
722736 EventPush p -> do
723737 subscribed <- getPushSubscribed p
@@ -756,7 +770,7 @@ zeroRef = unsafePerformIO $ newIORef 0
756770
757771getEventSubscribed :: Event a -> EventM (EventSubscribed a)
758772getEventSubscribed e = case e of
759− EventRoot r -> liftM EventSubscribedRoot $ getRootSubscribed r
773+ EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r
760774 EventNever -> return EventSubscribedNever
761775 EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p
762776 EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f
@@ -793,7 +807,7 @@ subscribeEventSubscribed es ws = case es of
793807
794808getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)
795809getEventSubscribedOcc es = case es of
796− EventSubscribedRoot r -> readIORef $ rootSubscribedOccurrence r
810+ EventSubscribedRoot r -> rootSubscribedOccurrence r
797811 EventSubscribedNever -> return Nothing
798812 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed
799813 EventSubscribedFan k subscribed -> do
@@ -824,21 +838,21 @@ noinlineFalse :: Bool
824838noinlineFalse = False
825839{-# NOINLINE noinlineFalse #-}
826840
827−getRootSubscribed :: Root a -> EventM (RootSubscribed a)
828−getRootSubscribed r = do
841+getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)
842+getRootSubscribed k r = do
829843 mSubscribed <- liftIO $ readIORef $ rootSubscribed r
830− case mSubscribed of
844+ case DMap.lookup (WrapArg k) mSubscribed of
831845 Just subscribed -> return subscribed
832846 Nothing -> liftIO $ do
833847 subscribersRef <- newIORef []
834− subscribed <- newRootSubscribed (rootOccurrence r) subscribersRef
848+ subscribed <- newRootSubscribed (liftM (DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef
835849 -- 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
836− uninit <- rootInit r $ RootTrigger (subscribersRef, rootOccurrence r)
850+ uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)
837851 addFinalizer subscribed $ do
838852 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should
839853-- putStrLn "Uninit root"
840854 uninit
841− liftIO $ writeIORef (rootSubscribed r) $ Just subscribed
855+ liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert (WrapArg k) subscribed
842856 return subscribed
843857
844858-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
@@ -1057,9 +1071,10 @@ runFrame a = do
10571071 holdInitRef <- newIORef []
10581072 heightRef <- newIORef 0
10591073 toClearRef <- newIORef []
1074+ toClearRootRef <- newIORef []
10601075 coincidenceInfosRef <- newIORef []
10611076 delayedRef <- liftIO $ newIORef IntMap.empty
1062− result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef heightRef coincidenceInfosRef delayedRef) $ do
1077+ result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) $ do
10631078 result <- a
10641079 let runHoldInits = do
10651080 holdInits <- liftIO $ readIORef holdInitRef
@@ -1071,6 +1086,8 @@ runFrame a = do
10711086 return result
10721087 toClear <- readIORef toClearRef
10731088 forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing
1089+ toClearRoot <- readIORef toClearRootRef
1090+ forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty
10741091 toAssign <- readIORef toAssignRef
10751092 toReconnectRef <- newIORef []
10761093 forM_ toAssign $ \(SomeAssignment h v) -> do
@@ -1323,16 +1340,22 @@ instance R.MonadHold Spider EventM where
13231340 {-# INLINE hold #-}
13241341 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)
13251342
1326−newtype RootTrigger a = RootTrigger (IORef [WeakSubscriber a], IORef (Maybe a))
1343+data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k), k a)
1344+newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }
1345+
1346+instance R.MonadSubscribeEvent Spider SpiderHostFrame where
1347+ subscribeEvent e = SpiderHostFrame $ do
1348+ _ <- getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
1349+ return $ SpiderEventHandle (unSpiderEvent e)
13271350
13281351instance R.ReflexHost Spider where
13291352 type EventTrigger Spider = RootTrigger
1330− type EventHandle Spider = R.Event Spider
1353+ type EventHandle Spider = SpiderEventHandle
13311354 type HostFrame Spider = SpiderHostFrame
13321355
1333−instance R.MonadReadEvent Spider ResultM where
1356+instance R.MonadReadEvent Spider ReadPhase where
13341357 {-# INLINE readEvent #-}
1335− readEvent = liftM (fmap return) . readEvent . unSpiderEvent
1358+ readEvent = ReadPhase . liftM (fmap return) . readEvent . unEventHandle
13361359
13371360instance MonadRef EventM where
13381361 type Ref EventM = Ref IO
@@ -1347,9 +1370,9 @@ instance MonadAtomicRef EventM where
13471370 {-# INLINE atomicModifyRef #-}
13481371 atomicModifyRef r f = liftIO $ atomicModifyRef r f
13491372
1350−newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
1373+newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
13511374
1352−newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
1375+newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
13531376
13541377instance R.MonadSample Spider SpiderHostFrame where
13551378 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 @@ instance R.MonadHold Spider SpiderHostFrame where
13581381 {-# INLINE hold #-}
13591382 hold v0 e = SpiderHostFrame $ R.hold v0 e
13601383
1361−newEventWithTriggerIO :: (RootTrigger a -> IO (IO ())) -> IO (R.Event Spider a)
1384+newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
13621385newEventWithTriggerIO f = do
1363− occRef <- newIORef Nothing
1364− subscribedRef <- newIORef Nothing
1386+ es <- newFanEventWithTriggerIO $ \Refl -> f
1387+ return $ select es Refl
1388+
1389+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)
1390+newFanEventWithTriggerIO f = do
1391+ occRef <- newIORef DMap.empty
1392+ subscribedRef <- newIORef DMap.empty
13651393 let !r = Root
13661394 { rootOccurrence = occRef
13671395 , rootSubscribed = subscribedRef
13681396 , rootInit = f
13691397 }
1370− return $ SpiderEvent $ EventRoot r
1398+ return $ EventSelector $ \k -> EventRoot k r
13711399
13721400instance R.MonadReflexCreateTrigger Spider SpiderHost where
1373− newEventWithTrigger = SpiderHost . newEventWithTriggerIO
1401+ newEventWithTrigger = SpiderHost . liftM SpiderEvent . newEventWithTriggerIO
1402+ newFanEventWithTrigger f = SpiderHost $ do
1403+ es <- newFanEventWithTriggerIO f
1404+ return $ R.EventSelector $ SpiderEvent . select es
13741405
13751406instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where
1376− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . newEventWithTriggerIO
1407+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO
1408+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
1409+ es <- newFanEventWithTriggerIO f
1410+ return $ R.EventSelector $ SpiderEvent . select es
13771411
1378−instance R.MonadReflexHost Spider SpiderHost where
1379− fireEventsAndRead es a = SpiderHost $ run es a
1412+instance R.MonadSubscribeEvent Spider SpiderHost where
13801413 subscribeEvent e = SpiderHost $ do
13811414 _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
1382− return e
1383− runFrame = SpiderHost . runFrame
1415+ return $ SpiderEventHandle (unSpiderEvent e)
1416+
1417+newtype ReadPhase a = ReadPhase { runReadPhase :: ResultM a } deriving (Functor, Applicative, Monad, MonadFix, R.MonadSample Spider, R.MonadHold Spider)
1418+
1419+instance R.MonadReflexHost Spider SpiderHost where
1420+ type ReadPhase SpiderHost = ReadPhase
1421+ fireEventsAndRead es (ReadPhase a) = SpiderHost $ run es a
13841422 runHostFrame = SpiderHost . runFrame . runSpiderHostFrame
13851423
13861424instance MonadRef SpiderHost where
test/Reflex/Pure.hsnew file+46
@@ -0,0 +1,46 @@
1+{- | 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.
2+-}
3+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, EmptyDataDecls #-}
4+module Reflex.Pure where
5+
6+import Reflex.Class
7+import Data.Functor.Misc
8+
9+import Control.Monad
10+import Data.MemoTrie
11+import qualified Data.Dependent.Map as DMap
12+
13+data Pure t
14+
15+-- | 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
16+-- The HasTrie instance will be used exclusively to memoize functions of t, not for any of its other capabilities
17+instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
18+ newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
19+ newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
20+ type PushM (Pure t) = (->) t
21+ type PullM (Pure t) = (->) t
22+ never = Event $ \_ -> Nothing
23+ constant x = Behavior $ \_ -> x
24+ push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
25+ pull = Behavior . memo
26+ merge events = Event $ memo $ \t ->
27+ let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events
28+ in if DMap.null currentOccurrences
29+ then Nothing
30+ else Just currentOccurrences
31+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k
32+ switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
33+ coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
34+
35+instance Ord t => MonadSample (Pure t) ((->) t) where
36+ sample = unBehavior
37+
38+instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
39+ hold initialValue e initialTime = Behavior f
40+ where f = memo $ \sampleTime ->
41+ 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
42+ then initialValue
43+ else let lastTime = pred sampleTime
44+ in case unEvent e lastTime of
45+ Nothing -> f lastTime
46+ Just x -> x
test/Reflex/Test/CrossImpl.hsnew file+228
@@ -0,0 +1,228 @@
1+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, BangPatterns, ConstraintKinds #-}
2+module Reflex.Test.CrossImpl (test) where
3+
4+import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl, and)
5+
6+import Reflex.Class
7+import Reflex.Host.Class
8+import Reflex.Dynamic
9+import qualified Reflex.Spider.Internal as S
10+import qualified Reflex.Pure as P
11+import Control.Monad.Ref
12+
13+import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
14+import qualified Data.Set as Set
15+import Data.Map.Strict (Map)
16+import qualified Data.Map.Strict as Map
17+import Control.Arrow (second, (&&&))
18+import Data.Traversable
19+import Data.Foldable
20+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
21+import Control.Monad.Writer hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
22+import Data.Dependent.Map (DSum (..))
23+import System.Mem
24+import System.Exit
25+
26+import System.IO.Unsafe
27+
28+mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
29+mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
30+ Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
31+ Just (_, v) -> v
32+
33+mapToPureEvent :: Map Int a -> Event PureReflexDomain a
34+mapToPureEvent m = P.Event $ flip Map.lookup m
35+
36+relevantTestingTimes :: (Map Int a, Map Int b) -> [Int]
37+relevantTestingTimes (b, e) = case Set.minView &&& Set.maxView $ Map.keysSet b `Set.union` Map.keysSet e of
38+ (Just (t0, _), Just (t1, _)) -> [t0..t1+1] -- We need to go to b+1 to see the result of the final event
39+ _ -> [] -- Doesn't actually make much sense
40+
41+type PureReflexDomain = P.Pure Int
42+type TimeM = (->) Int
43+
44+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)
45+testPure builder (b, e) =
46+ let (P.Behavior b', P.Event e') = ($ 0) $ builder (mapToPureBehavior b, mapToPureEvent e)
47+ relevantTimes = relevantTestingTimes (b, e)
48+ e'' = Map.mapMaybe id $ Map.fromList $ map (id &&& e') relevantTimes
49+ b'' = Map.fromList $ map (id &&& b') relevantTimes
50+ in (b'', e'')
51+
52+class MapMSignals a a' t t' | a -> t, a' -> t', a t' -> a', a' t -> a where
53+ mapMSignals :: Monad m => (forall b. Behavior t b -> m (Behavior t' b)) -> (forall b. Event t b -> m (Event t' b)) -> a -> m a'
54+
55+instance MapMSignals (Behavior t a) (Behavior t' a) t t' where
56+ mapMSignals fb _ = fb
57+
58+instance MapMSignals (Event t a) (Event t' a) t t' where
59+ mapMSignals _ fe = fe
60+
61+instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
62+ mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
63+
64+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)
65+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
66+ (re, reTrigger) <- newEventWithTriggerRef
67+ (rb, rbTrigger) <- newEventWithTriggerRef
68+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
69+ (b', e') <- runHostFrame $ builder (b, re)
70+ e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
71+ let times = relevantTestingTimes (bMap, eMap)
72+ liftIO performGC
73+ outputs <- forM times $ \t -> do
74+ forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> val]) =<< readRef rbTrigger
75+ bOutput <- sample b'
76+ eOutput <- liftM join $ forM (Map.lookup t eMap) $ \val -> do
77+ mret <- readRef reTrigger
78+ let firing = case mret of
79+ Just ret -> [ret :=> val]
80+ Nothing -> []
81+ fireEventsAndRead firing $ sequence =<< readEvent e'Handle
82+ liftIO performGC
83+ return (t, (bOutput, eOutput))
84+ return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs)
85+
86+tracePerf :: Show a => a -> b -> b
87+tracePerf = flip const
88+
89+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
90+testAgreement builder inputs = do
91+ let identityResult = testPure builder inputs
92+ tracePerf "---------" $ return ()
93+ let spiderResult = testSpider builder inputs
94+ tracePerf "---------" $ return ()
95+ let resultsAgree = identityResult == spiderResult
96+ if resultsAgree
97+ then do putStrLn "Success:"
98+ print identityResult
99+ else do putStrLn "Failure:"
100+ putStrLn $ "Pure result: " <> show identityResult
101+ putStrLn $ "Spider result: " <> show spiderResult
102+ return resultsAgree
103+
104+type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
105+
106+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))
107+
108+testCases :: [(String, TestCase)]
109+testCases =
110+ [ (,) "hold" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do
111+ b' <- hold "123" e
112+ return (b', e)
113+ , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do
114+ e' <- liftM updated $ count e
115+ b' <- hold (0 :: Int) e'
116+ return (b', e')
117+ , (,) "onceE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
118+ e' <- onceE $ leftmost [e, e]
119+ return (b, e')
120+ , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
121+ let e' = fmap (const e) e
122+ b' <- hold never e'
123+ let e'' = switch b'
124+ return (b, e'')
125+ , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
126+ let e' = flip pushAlways e $ const $ do
127+ let ea = fmap (const "a") e
128+ let eb = fmap (const "b") e
129+ let eab = leftmost [ea, eb]
130+ liftM switch $ hold eab never
131+ e'' = coincidence e'
132+ return (b, e'')
133+ , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
134+ let e' = flip pushAlways e $ const $ do
135+ let ea = fmap (const "a") e
136+ let eb = fmap (const "b") e
137+ let eab = leftmost [ea, eb]
138+ liftM switch $ hold eab (fmap (const e) e)
139+ e'' = coincidence e'
140+ return (b, e'')
141+ , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
142+ let e' = leftmost [e, e]
143+ e'' <- liftM switch $ hold e' (fmap (const e) e)
144+ return (b, e'')
145+ , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
146+ let e' = fmap (const e) e
147+ e'' <- switchPromptly never e'
148+ return (b, e'')
149+ , (,) "switchPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
150+ let e' = fmap (const e) e
151+ e'' <- switchPromptly never $ leftmost [e', e']
152+ return (b, e'')
153+ , (,) "switchPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
154+ let e' = leftmost [e, e]
155+ e'' <- switchPromptly never (fmap (const e) e')
156+ return (b, e'')
157+ , (,) "switchPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
158+ let e' = leftmost [e, e]
159+ e'' <- switchPromptly never (fmap (const e') e)
160+ return (b, e'')
161+ , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
162+ let e' = leftmost [e, e]
163+ e'' <- liftM switch $ hold never (fmap (const e') e)
164+ return (b, e'')
165+ , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
166+ let e' = flip push e $ \_ -> do
167+ return . Just =<< onceE e
168+ e'' <- switchPromptly never e'
169+ return (b, e'')
170+ , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
171+ let e' = flip pushAlways e $ \_ -> do
172+ switchPromptly e never
173+ e'' <- switchPromptly never e'
174+ return (b, e'')
175+ , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
176+ let e' = flip pushAlways e $ \_ -> return $ fmap id e
177+ e'' = coincidence e'
178+ return (b, e'')
179+ , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
180+ let e' = flip pushAlways e $ \_ -> return $ leftmost [e, e]
181+ e'' = coincidence e'
182+ return (b, e'')
183+ , (,) "coincidence-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
184+ let e' = flip pushAlways e $ \_ -> return $ coincidence $ fmap (const e) e
185+ e'' = coincidence e'
186+ return (b, e'')
187+ , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
188+ let e' = flip pushAlways e $ \_ -> onceE e
189+ e'' = coincidence e'
190+ return (b, e'')
191+ , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
192+ let eChild = flip pushAlways e $ const $ do
193+ let eNewValues = leftmost [e, e]
194+ return $ coincidence $ fmap (const eNewValues) eNewValues
195+ e' = coincidence eChild
196+ return (b, e')
197+ , (,) "coincidence-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
198+ let eChild = flip pushAlways e $ const $ do
199+ let e' = coincidence $ fmap (const e) e
200+ return $ leftmost [e', e']
201+ e'' = coincidence eChild
202+ return (b, e'')
203+ , (,) "coincidence-7" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
204+ let e' = leftmost [e, e]
205+ eCoincidences = coincidence $ fmap (const e') e
206+ return (b, eCoincidences)
207+ , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
208+ eo <- onceE e
209+ bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo
210+ let b' = pull $ sample =<< sample bb
211+ return (b', e)
212+ , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
213+ bb <- hold "b" e
214+ bd <- hold never . fmap (const e) =<< onceE e
215+ eOuter <- liftM (pushAlways sample . fmap (const bb)) $ onceE e
216+ let eInner = switch bd
217+ e' = leftmost [eOuter, eInner]
218+ return (b, e')
219+ ]
220+
221+test :: IO ()
222+test = do
223+ results <- forM testCases $ \(name, TestCase inputs builder) -> do
224+ putStrLn $ "Test: " <> name
225+ testAgreement builder inputs
226+ exitWith $ if and results
227+ then ExitSuccess
228+ else ExitFailure 1