e7e40d0 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Merge branch 'develop'

e7e40d0Ryan Trinkle11 years ago

.ghci+1−1

compare with develop

unifiedsplit

@@ -1,4 +1,4 @@

1:set -isrc

2:set -hide-package MonadCatchIO-mtl

3: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 @@

1{ mkDerivation, dependent-map, dependent-sum

2−, mtl, ref-tf, semigroups, these

2+, mtl, ref-tf, semigroups, these, MemoTrie, exception-transformers

3}:

4mkDerivation {

5 pname = "reflex";

6− version = "0.2";

6+ version = "0.3";

7 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;

8 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

10 ];

13 ];

11 license = null;

14 license = null;

12}

15}

reflex.cabal+22−4

@@ -1,5 +1,5 @@

1Name: reflex

2−Version: 0.2

2+Version: 0.3

3Synopsis: Higher-order Functional Reactive Programming

4Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system

5License: BSD3

@@ -23,9 +23,12 @@ library

23 mtl >= 2.1 && < 2.3,

24 containers == 0.5.*,

25 these == 0.4.*,

26− primitive == 0.5.*,

26+ primitive >= 0.5 && < 0.7,

27 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

30 exposed-modules:

33 exposed-modules:

31 Reflex,

34 Reflex,

@@ -38,9 +41,24 @@ library

38 Data.Functor.Misc

41 Data.Functor.Misc

40 other-extensions: TemplateHaskell

43 other-extensions: TemplateHaskell

41− ghc-prof-options: -fprof-auto

42 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

44 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

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+

44benchmark spider-bench

62benchmark spider-bench

45 type: exitcode-stdio-1.0

63 type: exitcode-stdio-1.0

46 hs-source-dirs: bench

64 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 #-}

2module Data.Functor.Misc where

4import Data.GADT.Compare

@@ -8,8 +8,9 @@ import Data.Dependent.Map (DMap, DSum (..))

8import qualified Data.Dependent.Map as DMap

9import Data.Typeable hiding (Refl)

10import Data.These

11+import Data.Maybe

12−data WrapArg :: (* -> *) -> (* -> *) -> * -> * where

13+data WrapArg :: (k -> *) -> (k -> *) -> * -> * where

13 WrapArg :: f a -> WrapArg g f (g a)

14 WrapArg :: f a -> WrapArg g f (g a)

15instance GEq f => GEq (WrapArg g f) where

16instance GEq f => GEq (WrapArg g f) where

@@ -61,6 +62,9 @@ rewrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> WrapArg k :

61unwrapDMap :: (forall a. f a -> a) -> DMap (WrapArg f k) -> DMap k

62unwrapDMap :: (forall a. f a -> a) -> DMap (WrapArg f k) -> DMap k

62unwrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> k :=> f v) . DMap.toAscList

63unwrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> k :=> f v) . DMap.toAscList

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+

64mapToDMap :: Map k v -> DMap (Const2 k v)

68mapToDMap :: Map k v -> DMap (Const2 k v)

65mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList

69mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList

src/Reflex/Class.hs+72−7

@@ -1,11 +1,14 @@

1{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase #-}

2module Reflex.Class where

4−import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)

4+import Control.Applicative

5−

6import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

5import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

7import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

6import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

8import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

7import 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())

9import Data.List.NonEmpty (NonEmpty (..))

12import Data.List.NonEmpty (NonEmpty (..))

10import Data.These

13import Data.These

11import Data.Align

14import Data.Align

@@ -17,10 +20,14 @@ import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))

17import qualified Data.Dependent.Map as DMap

20import qualified Data.Dependent.Map as DMap

18import Data.Functor.Misc

21import Data.Functor.Misc

19import Data.Semigroup

22import 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)

21import Debug.Trace (trace)

28import Debug.Trace (trace)

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

24 -- | 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

31 -- | 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

25 data Behavior t :: * -> *

32 data Behavior t :: * -> *

26 -- | 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")

33 -- | 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

39 type PullM t :: * -> *

46 type PullM t :: * -> *

40 -- | 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

47 -- | 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

41 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

48 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

43 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

50 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

44 -- | Create an Event that will occur whenever the currently-selected input Event occurs

51 -- | Create an Event that will occur whenever the currently-selected input Event occurs

45 switch :: Behavior t (Event t a) -> Event t a

52 switch :: Behavior t (Event t a) -> Event t a

46 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring

53 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring

47 coincidence :: Event t (Event t a) -> Event t a

54 coincidence :: Event t (Event t a) -> Event t a

49−class Monad m => MonadSample t m | m -> t where

56+class (Applicative m, Monad m) => MonadSample t m | m -> t where

50 -- | Get the current value in the Behavior

57 -- | Get the current value in the Behavior

51 sample :: Behavior t a -> m a

58 sample :: Behavior t a -> m a

@@ -66,6 +73,36 @@ instance MonadSample t m => MonadSample t (ReaderT r m) where

66instance MonadHold t m => MonadHold t (ReaderT r m) where

73instance MonadHold t m => MonadHold t (ReaderT r m) where

67 hold a0 = lift . hold a0

74 hold a0 = lift . hold a0

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+

69--------------------------------------------------------------------------------

106--------------------------------------------------------------------------------

70-- Convenience functions

107-- Convenience functions

71--------------------------------------------------------------------------------

108--------------------------------------------------------------------------------

@@ -73,7 +110,7 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where

73-- | Create an Event from another Event.

110-- | Create an Event from another Event.

74-- The provided function can sample 'Behavior's and hold 'Event's.

111-- The provided function can sample 'Behavior's and hold 'Event's.

75pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

112pushAlways :: 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)

114

78-- | Flipped version of 'fmap'.

115-- | Flipped version of 'fmap'.

79ffor :: Functor f => f a -> (a -> b) -> f b

116ffor :: Functor f => f a -> (a -> b) -> f b

@@ -82,6 +119,28 @@ ffor = flip fmap

82instance Reflex t => Functor (Behavior t) where

119instance Reflex t => Functor (Behavior t) where

83 fmap f = pull . liftM f . sample

120 fmap f = pull . liftM f . sample

121

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+

85--TODO: See if there's a better class in the standard libraries already

144--TODO: See if there's a better class in the standard libraries already

86-- | A class for values that combines filtering and mapping using 'Maybe'.

145-- | A class for values that combines filtering and mapping using 'Maybe'.

87class FunctorMaybe f where

146class FunctorMaybe f where

@@ -239,7 +298,7 @@ dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of

239-- 'Event's occurs. If both occur at the same time they are combined

298-- 'Event's occurs. If both occur at the same time they are combined

240-- using 'mappend'.

299-- using 'mappend'.

241appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a

300appendEvents :: (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

243

302

244{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}

303{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}

245sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)

304sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)

@@ -299,3 +358,9 @@ instance Reflex t => Align (Event t) where

299-- occurs and the 'Behavior' is true at the time of occurence.

358-- occurs and the 'Behavior' is true at the time of occurence.

300gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a

359gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a

301gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing

360gate = 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

156-- time the 'Event' occurs using a folding function on the previous

157-- value and the value of the 'Event'.

158foldDyn :: (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

160

161-- | Create a 'Dynamic' using the initial value and change it each

162-- time the 'Event' occurs using a monadic folding function on the

163-- previous value and the value of the 'Event'.

164foldDynM :: (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

166 rec let e' = flip push e $ \o -> do

172 rec let e' = flip push e $ \o -> do

167 v <- sample b'

173 v <- sample b'

168− liftM Just $ f o v

174+ f o v

169 b' <- hold z e'

175 b' <- hold z e'

170 return $ Dynamic b' e'

176 return $ Dynamic b' e'

171

177

@@ -421,12 +427,20 @@ class RebuildSortedHList l where

421 rebuildSortedHList :: [DSum (HListPtr l)] -> HList l

427 rebuildSortedHList :: [DSum (HListPtr l)] -> HList l

422

428

423instance RebuildSortedHList '[] where

429instance RebuildSortedHList '[] where

424− rebuildSortedFHList [] = FHNil

430+ rebuildSortedFHList l = case l of

431+ [] -> FHNil

432+ _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"

425− rebuildSortedHList [] = HNil

433+ rebuildSortedHList l = case l of

434+ [] -> HNil

435+ _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"

426

436

427instance RebuildSortedHList t => RebuildSortedHList (h ': t) where

437instance RebuildSortedHList t => RebuildSortedHList (h ': t) where

438+ rebuildSortedFHList l = case l of

428− rebuildSortedFHList ((WrapArg HHeadPtr :=> h) : t) = FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t

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

429− rebuildSortedHList ((HHeadPtr :=> h) : t) = HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t

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"

430

444

431dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l

445dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l

432dmapToHList = rebuildSortedHList . DMap.toList

446dmapToHList = rebuildSortedHList . DMap.toList

@@ -449,12 +463,16 @@ class AllAreFunctors (f :: a -> *) (l :: [a]) where

449

463

450instance AllAreFunctors f '[] where

464instance AllAreFunctors f '[] where

451 type FunctorList f '[] = '[]

465 type FunctorList f '[] = '[]

466+ toFHList l = case l of

452− toFHList HNil = FHNil

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

453 fromFHList FHNil = HNil

469 fromFHList FHNil = HNil

454

470

455instance AllAreFunctors f t => AllAreFunctors f (h ': t) where

471instance AllAreFunctors f t => AllAreFunctors f (h ': t) where

456 type FunctorList f (h ': t) = f h ': FunctorList f t

472 type FunctorList f (h ': t) = f h ': FunctorList f t

473+ toFHList l = case l of

457− toFHList (a `HCons` b) = a `FHCons` toFHList b

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

458 fromFHList (a `FHCons` b) = a `HCons` fromFHList b

476 fromFHList (a `FHCons` b) = a `HCons` fromFHList b

459

477

460collectDyn :: ( RebuildSortedHList (HListElems b)

478collectDyn :: ( RebuildSortedHList (HListElems b)

@@ -475,14 +493,20 @@ class IsHList a where

475instance IsHList (a, b) where

493instance IsHList (a, b) where

476 type HListElems (a, b) = [a, b]

494 type HListElems (a, b) = [a, b]

477 toHList (a, b) = hBuild a b

495 toHList (a, b) = hBuild a b

496+ fromHList l = case l of

478− fromHList (a `HCons` b `HCons` HNil) = (a, b)

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

479

499

480instance IsHList (a, b, c, d) where

500instance IsHList (a, b, c, d) where

481 type HListElems (a, b, c, d) = [a, b, c, d]

501 type HListElems (a, b, c, d) = [a, b, c, d]

482 toHList (a, b, c, d) = hBuild a b c d

502 toHList (a, b, c, d) = hBuild a b c d

503+ fromHList l = case l of

483− fromHList (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a, b, c, d)

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

484

506

485instance IsHList (a, b, c, d, e, f) where

507instance IsHList (a, b, c, d, e, f) where

486 type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]

508 type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]

487 toHList (a, b, c, d, e, f) = hBuild a b c d e f

509 toHList (a, b, c, d, e, f) = hBuild a b c d e f

510+ fromHList l = case l of

488− fromHList (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a, b, c, d, e, f)

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 #-}

2module Reflex.Host.Class where

4−import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)

5−

6import Reflex.Class

4import Reflex.Class

8−import Control.Monad.State.Strict 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.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)

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())

10import Data.Dependent.Sum (DSum)

15import Data.Dependent.Sum (DSum)

16+import Data.Monoid

17+import Data.GADT.Compare

11import Control.Monad.Ref

18import Control.Monad.Ref

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

14 type EventTrigger t :: * -> *

25 type EventTrigger t :: * -> *

15 type EventHandle t :: * -> *

26 type EventHandle t :: * -> *

16 type HostFrame t :: * -> *

27 type HostFrame t :: * -> *

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.

18−class (ReflexHost t, Monad m) => MonadReadEvent t m | m -> t where

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'.

19 readEvent :: EventHandle t a -> m (Maybe (m a))

52 readEvent :: EventHandle t a -> m (Maybe (m a))

54+-- | A monad where new events feed from external sources can be created.

21−class (Monad m, ReflexHost t) => MonadReflexCreateTrigger t m | m -> t where

55+class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where

22− -- | Creates an original Event (one that is not based on any other event).

56+ -- | Creates a root 'Event' (one that is not based on any other event).

57+ --

23 -- When a subscriber first subscribes to an event (building another event

58 -- When a subscriber first subscribes to an event (building another event

24− -- that depends on the subscription) the given callback function is run by

59+ -- that depends on the subscription) the given callback function is run and

25− -- passing a trigger. The event is then set up in IO. The callback

60+ -- passed a trigger. The callback function can then set up the event source in IO.

26− -- function returns an accompanying teardown action.

61+ -- After this is done, the callback function must return an accompanying teardown action.

62+ --

27 -- Any time between setup and teardown the trigger can be used to fire

63 -- 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.

29 newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)

67 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

31−class (Monad m, ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexHost t m | m -> t where

87+ -- | Run a frame without any events firing.

32− fireEventsAndRead :: [DSum (EventTrigger t)] -> (forall m'. (MonadReadEvent t m') => m' a) -> m a

88+ --

33− subscribeEvent :: Event t a -> m (EventHandle t a) --TODO: Return a handle, and use them in fireEventsAnRead

89+ -- This function should be used when you want to use 'sample' and 'hold' when no events are currently firing.

34− runFrame :: PushM t a -> m a

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.

35 runHostFrame :: HostFrame t a -> m a

94 runHostFrame :: HostFrame t a -> m a

96+-- | Like 'fireEventsAndRead', but without reading any events.

37fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t)] -> m ()

97fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t)] -> m ()

38−{-# INLINE fireEvents #-}

39fireEvents dm = fireEventsAndRead dm $ return ()

98fireEvents dm = fireEventsAndRead dm $ return ()

99+{-# INLINE fireEvents #-}

100

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.

42newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a)))

107newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a)))

43newEventWithTriggerRef = do

108newEventWithTriggerRef = do

44 rt <- newRef Nothing

109 rt <- newRef Nothing

@@ -46,17 +111,80 @@ newEventWithTriggerRef = do

46 writeRef rt $ Just t

111 writeRef rt $ Just t

47 return $ writeRef rt Nothing

112 return $ writeRef rt Nothing

48 return (e, rt)

113 return (e, rt)

114+{-# INLINE newEventWithTriggerRef #-}

115

50--------------------------------------------------------------------------------

116--------------------------------------------------------------------------------

51-- Instances

117-- Instances

52--------------------------------------------------------------------------------

118--------------------------------------------------------------------------------

119

54−instance (Reflex t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (ReaderT r m) where

120+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ReaderT r m) where

55− newEventWithTrigger initializer = do

121+ newEventWithTrigger = lift . newEventWithTrigger

56− lift $ newEventWithTrigger initializer

122+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer

123

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+

58−instance (Reflex t, MonadReflexHost t m) => MonadReflexHost t (ReaderT r m) where

139+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (WriterT w m) where

140+ type ReadPhase (WriterT w m) = ReadPhase m

59 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a

141 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

60 subscribeEvent = lift . subscribeEvent

149 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

62 runHostFrame = lift . runHostFrame

190 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 #-}

2module Reflex.Spider.Internal where

4−import Prelude hiding (mapM, mapM_, any, sequence, concat)

5−

6import qualified Reflex.Class as R

4import qualified Reflex.Class as R

7import qualified Reflex.Host.Class as R

5import qualified Reflex.Host.Class as R

@@ -13,9 +11,7 @@ import Data.Traversable

13import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)

11import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)

14import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)

12import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)

15import GHC.Exts

13import GHC.Exts

16−#if !MIN_VERSION_base(4,8,0)

17−import Control.Applicative

14+import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2

18−#endif

19import Data.Dependent.Map (DMap, DSum (..))

15import Data.Dependent.Map (DMap, DSum (..))

20import qualified Data.Dependent.Map as DMap

16import qualified Data.Dependent.Map as DMap

21import Data.GADT.Compare

17import Data.GADT.Compare

@@ -24,12 +20,16 @@ import Data.Maybe

24import Data.IntMap (IntMap)

20import Data.IntMap (IntMap)

25import qualified Data.IntMap as IntMap

21import qualified Data.IntMap as IntMap

26import Control.Monad.Ref

22import Control.Monad.Ref

23+import Control.Monad.Exception

27import Data.Monoid ((<>))

24import Data.Monoid ((<>))

29import System.IO.Unsafe

26import System.IO.Unsafe

30import Unsafe.Coerce

27import Unsafe.Coerce

31import Control.Monad.Primitive

28import Control.Monad.Primitive

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+

33debugPropagate :: Bool

35debugInvalidateHeight :: Bool

@@ -109,6 +109,7 @@ data EventEnv

109 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment])

110 , eventEnvHoldInits :: !(IORef [SomeHoldInit])

111 , eventEnvClears :: !(IORef [SomeMaybeIORef])

112+ , eventEnvRootClears :: !(IORef [SomeDMapIORef])

112 , eventEnvCurrentHeight :: !(IORef Int)

113 , eventEnvCurrentHeight :: !(IORef Int)

113 , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])

114 , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])

114 , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))

115 , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))

@@ -138,6 +139,11 @@ scheduleClear r = EventM $ do

138 clears <- asks eventEnvClears

139 clears <- asks eventEnvClears

139 liftIO $ modifyIORef' clears (SomeMaybeIORef r :)

140 liftIO $ modifyIORef' clears (SomeMaybeIORef r :)

140

141

142+scheduleRootClear :: IORef (DMap k) -> EventM ()

143+scheduleRootClear r = EventM $ do

144+ clears <- asks eventEnvRootClears

145+ liftIO $ modifyIORef' clears (SomeDMapIORef r :)

146+

141scheduleMerge :: Int -> MergeSubscribed a -> EventM ()

147scheduleMerge :: Int -> MergeSubscribed a -> EventM ()

142scheduleMerge height subscribed = EventM $ do

148scheduleMerge height subscribed = EventM $ do

143 delayedRef <- asks eventEnvDelayedMerges

149 delayedRef <- asks eventEnvDelayedMerges

@@ -213,19 +219,19 @@ data Invalidator

213

219

214data RootSubscribed a

220data RootSubscribed a

215 = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])

221 = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])

216− , rootSubscribedOccurrence :: !(IORef (Maybe a)) -- Alias to rootOccurrence

222+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence

217 }

223 }

218

224

219−data Root a

225+data Root (k :: * -> *)

220− = Root { rootOccurrence :: !(IORef (Maybe a)) -- The currently-firing occurrence of this event

226+ = Root { rootOccurrence :: !(IORef (DMap k)) -- The currently-firing occurrence of this event

221− , rootSubscribed :: !(IORef (Maybe (RootSubscribed a)))

227+ , rootSubscribed :: !(IORef (DMap (WrapArg RootSubscribed k)))

222− , rootInit :: !(RootTrigger a -> IO (IO ()))

228+ , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))

223 }

229 }

224

230

225data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)

231data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)

226

232

227-- EventM can do everything BehaviorM can, plus create holds

233-- 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

229

235

230data PushSubscribed a b

236data PushSubscribed a b

231 = 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)

237 = 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

365 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

371 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

366

372

367data Event a

373data Event a

368− = EventRoot !(Root a)

374+ = forall k. GCompare k => EventRoot !(k a) !(Root k)

369 | EventNever

375 | EventNever

370 | forall b. EventPush !(Push b a)

376 | forall b. EventPush !(Push b a)

371 | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)

377 | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)

@@ -375,7 +381,7 @@ data Event a

375

381

376showEventType :: Event a -> String

382showEventType :: Event a -> String

377showEventType = \case

383showEventType = \case

378− EventRoot _ -> "EventRoot"

384+ EventRoot _ _ -> "EventRoot"

379 EventNever -> "EventNever"

385 EventNever -> "EventNever"

380 EventPush _ -> "EventPush"

386 EventPush _ -> "EventPush"

381 EventMerge _ -> "EventMerge"

387 EventMerge _ -> "EventMerge"

@@ -402,7 +408,7 @@ data EventSubscribed a

402-- the weak pointer to it in some cases.

408-- the weak pointer to it in some cases.

403

409

404{-# NOINLINE newRootSubscribed #-}

410{-# NOINLINE newRootSubscribed #-}

405−newRootSubscribed :: IORef (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)

411+newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)

406newRootSubscribed occ subs =

412newRootSubscribed occ subs =

407 return $! RootSubscribed

413 return $! RootSubscribed

408 { rootSubscribedOccurrence = occ

414 { rootSubscribedOccurrence = occ

@@ -495,14 +501,14 @@ coincidence a = EventCoincidence $ Coincidence

495 , coincidenceSubscribed = unsafeNewIORef a Nothing

501 , coincidenceSubscribed = unsafeNewIORef a Nothing

496 }

502 }

497

503

498−newRoot :: IO (Root a)

504+newRoot :: IO (Root k)

499newRoot = do

505newRoot = do

500− occRef <- newIORef Nothing

506+ occRef <- newIORef DMap.empty

501− subscribedRef <- newIORef Nothing

507+ subscribedRef <- newIORef DMap.empty

502 return $ Root

508 return $ Root

503 { rootOccurrence = occRef

509 { rootOccurrence = occRef

504 , rootSubscribed = subscribedRef

510 , rootSubscribed = subscribedRef

505− , rootInit = const $ return $ return ()

511+ , rootInit = \_ _ -> return $ return ()

506 }

512 }

507

513

508propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()

514propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()

@@ -517,10 +523,16 @@ run :: [DSum RootTrigger] -> ResultM b -> IO b

517run roots after = do

523run roots after = do

518 when debugPropagate $ putStrLn "Running an event frame"

524 when debugPropagate $ putStrLn "Running an event frame"

519 result <- runFrame $ do

525 result <- runFrame $ do

520− forM_ roots $ \(RootTrigger (_, occRef) :=> a) -> do

526+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

527+ occBefore <- liftIO $ do

528+ occBefore <- readIORef occRef

521− liftIO $ writeIORef occRef $ Just a

529+ writeIORef occRef $ DMap.insert k a occBefore

522− scheduleClear occRef

530+ return occBefore

531+ if DMap.null occBefore

532+ then do scheduleRootClear occRef

533+ return $ Just r

534+ else return Nothing

523− forM_ roots $ \(RootTrigger (subscribersRef, _) :=> a) -> do

535+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> a) -> do

524 propagateAndUpdateSubscribersRef subscribersRef a

536 propagateAndUpdateSubscribersRef subscribersRef a

525 delayedRef <- EventM $ asks eventEnvDelayedMerges

537 delayedRef <- EventM $ asks eventEnvDelayedMerges

526 let go = do

538 let go = do

@@ -553,6 +565,8 @@ run roots after = do

553

565

554data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))

566data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))

555

567

568+data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k))

569+

556data SomeAssignment = forall a. SomeAssignment (Hold a) a

570data SomeAssignment = forall a. SomeAssignment (Hold a) a

557

571

558data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)

572data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)

@@ -717,7 +731,7 @@ readBehaviorTracked b = case b of

717

731

718readEvent :: Event a -> ResultM (Maybe a)

732readEvent :: Event a -> ResultM (Maybe a)

719readEvent e = case e of

733readEvent e = case e of

720− EventRoot r -> liftIO $ readIORef $ rootOccurrence r

734+ EventRoot k r -> liftIO $ liftM (DMap.lookup k) $ readIORef $ rootOccurrence r

721 EventNever -> return Nothing

735 EventNever -> return Nothing

722 EventPush p -> do

736 EventPush p -> do

723 subscribed <- getPushSubscribed p

737 subscribed <- getPushSubscribed p

@@ -756,7 +770,7 @@ zeroRef = unsafePerformIO $ newIORef 0

756

770

757getEventSubscribed :: Event a -> EventM (EventSubscribed a)

771getEventSubscribed :: Event a -> EventM (EventSubscribed a)

758getEventSubscribed e = case e of

772getEventSubscribed e = case e of

759− EventRoot r -> liftM EventSubscribedRoot $ getRootSubscribed r

773+ EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r

760 EventNever -> return EventSubscribedNever

774 EventNever -> return EventSubscribedNever

761 EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p

775 EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p

762 EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f

776 EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f

@@ -793,7 +807,7 @@ subscribeEventSubscribed es ws = case es of

793

807

794getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)

808getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)

795getEventSubscribedOcc es = case es of

809getEventSubscribedOcc es = case es of

796− EventSubscribedRoot r -> readIORef $ rootSubscribedOccurrence r

810+ EventSubscribedRoot r -> rootSubscribedOccurrence r

797 EventSubscribedNever -> return Nothing

811 EventSubscribedNever -> return Nothing

798 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed

812 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed

799 EventSubscribedFan k subscribed -> do

813 EventSubscribedFan k subscribed -> do

@@ -824,21 +838,21 @@ noinlineFalse :: Bool

824noinlineFalse = False

838noinlineFalse = False

825{-# NOINLINE noinlineFalse #-}

839{-# NOINLINE noinlineFalse #-}

826

840

827−getRootSubscribed :: Root a -> EventM (RootSubscribed a)

841+getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)

828−getRootSubscribed r = do

842+getRootSubscribed k r = do

829 mSubscribed <- liftIO $ readIORef $ rootSubscribed r

843 mSubscribed <- liftIO $ readIORef $ rootSubscribed r

830− case mSubscribed of

844+ case DMap.lookup (WrapArg k) mSubscribed of

831 Just subscribed -> return subscribed

845 Just subscribed -> return subscribed

832 Nothing -> liftIO $ do

846 Nothing -> liftIO $ do

833 subscribersRef <- newIORef []

847 subscribersRef <- newIORef []

834− subscribed <- newRootSubscribed (rootOccurrence r) subscribersRef

848+ subscribed <- newRootSubscribed (liftM (DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef

835 -- 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

849 -- 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)

837 addFinalizer subscribed $ do

851 addFinalizer subscribed $ do

838 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should

852 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should

839-- putStrLn "Uninit root"

853-- putStrLn "Uninit root"

840 uninit

854 uninit

841− liftIO $ writeIORef (rootSubscribed r) $ Just subscribed

855+ liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert (WrapArg k) subscribed

842 return subscribed

856 return subscribed

843

857

844-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in

858-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in

@@ -1057,9 +1071,10 @@ runFrame a = do

1057 holdInitRef <- newIORef []

1071 holdInitRef <- newIORef []

1058 heightRef <- newIORef 0

1072 heightRef <- newIORef 0

1059 toClearRef <- newIORef []

1073 toClearRef <- newIORef []

1074+ toClearRootRef <- newIORef []

1060 coincidenceInfosRef <- newIORef []

1075 coincidenceInfosRef <- newIORef []

1061 delayedRef <- liftIO $ newIORef IntMap.empty

1076 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

1063 result <- a

1078 result <- a

1064 let runHoldInits = do

1079 let runHoldInits = do

1065 holdInits <- liftIO $ readIORef holdInitRef

1080 holdInits <- liftIO $ readIORef holdInitRef

@@ -1071,6 +1086,8 @@ runFrame a = do

1071 return result

1086 return result

1072 toClear <- readIORef toClearRef

1087 toClear <- readIORef toClearRef

1073 forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing

1088 forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing

1089+ toClearRoot <- readIORef toClearRootRef

1090+ forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty

1074 toAssign <- readIORef toAssignRef

1091 toAssign <- readIORef toAssignRef

1075 toReconnectRef <- newIORef []

1092 toReconnectRef <- newIORef []

1076 forM_ toAssign $ \(SomeAssignment h v) -> do

1093 forM_ toAssign $ \(SomeAssignment h v) -> do

@@ -1323,16 +1340,22 @@ instance R.MonadHold Spider EventM where

1323 {-# INLINE hold #-}

1340 {-# INLINE hold #-}

1324 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)

1341 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)

1325

1342

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)

1327

1350

1328instance R.ReflexHost Spider where

1351instance R.ReflexHost Spider where

1329 type EventTrigger Spider = RootTrigger

1352 type EventTrigger Spider = RootTrigger

1330− type EventHandle Spider = R.Event Spider

1353+ type EventHandle Spider = SpiderEventHandle

1331 type HostFrame Spider = SpiderHostFrame

1354 type HostFrame Spider = SpiderHostFrame

1332

1355

1333−instance R.MonadReadEvent Spider ResultM where

1356+instance R.MonadReadEvent Spider ReadPhase where

1334 {-# INLINE readEvent #-}

1357 {-# INLINE readEvent #-}

1335− readEvent = liftM (fmap return) . readEvent . unSpiderEvent

1358+ readEvent = ReadPhase . liftM (fmap return) . readEvent . unEventHandle

1336

1359

1337instance MonadRef EventM where

1360instance MonadRef EventM where

1338 type Ref EventM = Ref IO

1361 type Ref EventM = Ref IO

@@ -1347,9 +1370,9 @@ instance MonadAtomicRef EventM where

1347 {-# INLINE atomicModifyRef #-}

1370 {-# INLINE atomicModifyRef #-}

1348 atomicModifyRef r f = liftIO $ atomicModifyRef r f

1371 atomicModifyRef r f = liftIO $ atomicModifyRef r f

1349

1372

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)

1351

1374

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)

1353

1376

1354instance R.MonadSample Spider SpiderHostFrame where

1377instance R.MonadSample Spider SpiderHostFrame where

1355 sample = SpiderHostFrame . R.sample --TODO: This can cause problems with laziness, so we should get rid of it if we can

1378 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

1358 {-# INLINE hold #-}

1381 {-# INLINE hold #-}

1359 hold v0 e = SpiderHostFrame $ R.hold v0 e

1382 hold v0 e = SpiderHostFrame $ R.hold v0 e

1360

1383

1361−newEventWithTriggerIO :: (RootTrigger a -> IO (IO ())) -> IO (R.Event Spider a)

1384+newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)

1362newEventWithTriggerIO f = do

1385newEventWithTriggerIO f = do

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

1363− occRef <- newIORef Nothing

1391+ occRef <- newIORef DMap.empty

1364− subscribedRef <- newIORef Nothing

1392+ subscribedRef <- newIORef DMap.empty

1365 let !r = Root

1393 let !r = Root

1366 { rootOccurrence = occRef

1394 { rootOccurrence = occRef

1367 , rootSubscribed = subscribedRef

1395 , rootSubscribed = subscribedRef

1368 , rootInit = f

1396 , rootInit = f

1369 }

1397 }

1370− return $ SpiderEvent $ EventRoot r

1398+ return $ EventSelector $ \k -> EventRoot k r

1371

1399

1372instance R.MonadReflexCreateTrigger Spider SpiderHost where

1400instance 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

1374

1405

1375instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where

1406instance 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

1377

1411

1378−instance R.MonadReflexHost Spider SpiderHost where

1412+instance R.MonadSubscribeEvent Spider SpiderHost where

1379− fireEventsAndRead es a = SpiderHost $ run es a

1380 subscribeEvent e = SpiderHost $ do

1413 subscribeEvent e = SpiderHost $ do

1381 _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used

1414 _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used

1382− return e

1415+ return $ SpiderEventHandle (unSpiderEvent e)

1383− runFrame = SpiderHost . runFrame

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

1384 runHostFrame = SpiderHost . runFrame . runSpiderHostFrame

1422 runHostFrame = SpiderHost . runFrame . runSpiderHostFrame

1385

1423

1386instance MonadRef SpiderHost where

1424instance 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

6+import Reflex.Class

7+import Data.Functor.Misc

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

4+import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl, and)

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