f49085a · reflex · git.iko.soy

git.iko.soy/reflex

Merge branch 'develop' into inlining

# Conflicts: # default.nix # src/Reflex/Spider/Internal.hs

commitf49085ab86f295686b22d72cffb2cd5f32fa0dcf authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 31 Aug 2016, 21:03 (10 years ago) parenta362550 a63aba9

13 files changed+694−113

compare with develop

unifiedsplit

default.nix+9−7 reflex.cabal+8−1 src/Reflex.hs+3 src/Reflex/Class.hs+35−1 src/Reflex/Deletable/Class.hs+17 src/Reflex/Dynamic.hs+18 src/Reflex/Dynamic/TH.hs+1−1 src/Reflex/DynamicWriter.hs+181 src/Reflex/PerformEvent/Base.hs+168 src/Reflex/PerformEvent/Class.hs+46 src/Reflex/PostBuild/Class.hs+91 src/Reflex/Spider.hs+13−6 src/Reflex/Spider/Internal.hs+104−97

default.nix+9−7

@@ -1,18 +1,20 @@

11{ mkDerivation, base, bifunctors, containers, deepseq

22, dependent-map, dependent-sum, exception-transformers

3−, haskell-src-exts, haskell-src-meta, hlint, MemoTrie, mtl

4−, primitive, ref-tf, semigroupoids, semigroups, split, stdenv, stm

5−, syb, template-haskell, these, transformers, transformers-compat

3+, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie

4+, monad-control, mtl, primitive, ref-tf, semigroupoids, semigroups

5+, split, stdenv, stm, syb, template-haskell, these, transformers

6+, transformers-compat

67}:

78mkDerivation {

89 pname = "reflex";

9− version = "0.4.0";

10+ version = "0.5.0";

1011 src = ./.;

1112 libraryHaskellDepends = [

1213 base bifunctors containers dependent-map dependent-sum

13− exception-transformers haskell-src-exts haskell-src-meta MemoTrie

14− mtl primitive ref-tf semigroupoids semigroups stm syb

15− template-haskell these transformers transformers-compat

14+ exception-transformers haskell-src-exts haskell-src-meta lens

15+ MemoTrie monad-control mtl primitive ref-tf semigroupoids

16+ semigroups stm syb template-haskell these transformers

17+ transformers-compat

1618 ];

1719 testHaskellDepends = [

1820 base bifunctors containers deepseq dependent-map dependent-sum

reflex.cabal+8−1

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

11Name: reflex

2−Version: 0.4.0

2+Version: 0.5.0

33Synopsis: Higher-order Functional Reactive Programming

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

55License: BSD3

@@ -25,6 +25,8 @@ library

2525 exception-transformers == 0.4.*,

2626 haskell-src-exts >= 1.16 && < 1.18,

2727 haskell-src-meta == 0.6.*,

28+ lens >= 4.7 && < 5,

29+ monad-control >= 1.0.1 && < 1.1,

2830 mtl >= 2.1 && < 2.3,

2931 primitive >= 0.5 && < 0.7,

3032 ref-tf == 0.4.*,

@@ -42,10 +44,15 @@ library

4244 Data.WeakBag,

4345 Reflex,

4446 Reflex.Class,

47+ Reflex.Deletable.Class,

4548 Reflex.Dynamic,

4649 Reflex.Dynamic.TH,

4750 Reflex.Dynamic.Uniq,

51+ Reflex.DynamicWriter,

4852 Reflex.Host.Class,

53+ Reflex.PerformEvent.Base,

54+ Reflex.PerformEvent.Class,

55+ Reflex.PostBuild.Class,

4956 Reflex.Pure,

5057 Reflex.Spider,

5158 Reflex.Spider.Internal

src/Reflex.hs+3

@@ -6,4 +6,7 @@ import Reflex.Class as X

66import Reflex.Dynamic as X

77import Reflex.Dynamic.TH as X

88import Reflex.Dynamic.Uniq as X

9+import Reflex.DynamicWriter as X

10+import Reflex.PerformEvent.Class as X

11+import Reflex.PostBuild.Class as X

912import Reflex.Spider as X

src/Reflex/Class.hs+35−1

@@ -36,6 +36,8 @@ module Reflex.Class

3636 , mergeWith

3737 -- ** Breaking up 'Event's

3838 , splitE

39+ , fanEither

40+ , fanThese

3941 , fanMap

4042 , dmapToThese

4143 , EitherTag (..)

@@ -52,6 +54,8 @@ module Reflex.Class

5254 , gate

5355 -- ** Combining 'Dynamic's

5456 , distributeDMapOverDynPure

57+ , distributeListOverDyn

58+ , distributeListOverDynWith

5559 , zipDyn

5660 , zipDynWith

5761 -- ** Accumulating state

@@ -63,6 +67,7 @@ module Reflex.Class

6367 , zipListWithEvent

6468 , headE

6569 , tailE

70+ , headTailE

6671 , switcher

6772 -- * Debugging functions

6873 , traceEvent

@@ -94,6 +99,7 @@ import Data.Bifunctor

9499import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))

95100import qualified Data.Dependent.Map as DMap

96101import Data.Dependent.Sum (ShowTag (..))

102+import Data.Either

97103import Data.Foldable

98104import Data.Functor.Bind hiding (join)

99105import qualified Data.Functor.Bind as Bind

@@ -598,6 +604,25 @@ mergeList es = mergeWith (<>) $ map (fmap (:|[])) es

598604mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)

599605mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

600606

607+-- | Split the event into separate events for 'Left' and 'Right' values.

608+fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)

609+fanEither e =

610+ let justLeft = either Just (const Nothing)

611+ justRight = either (const Nothing) Just

612+ in (fmapMaybe justLeft e, fmapMaybe justRight e)

613+

614+-- | Split the event into separate events for 'This' and 'That' values,

615+-- allowing them to fire simultaneously when the input value is 'These'.

616+fanThese :: Reflex t => Event t (These a b) -> (Event t a, Event t b)

617+fanThese e =

618+ let this (This x) = Just x

619+ this (These x _) = Just x

620+ this _ = Nothing

621+ that (That y) = Just y

622+ that (These _ y) = Just y

623+ that _ = Nothing

624+ in (fmapMaybe this e, fmapMaybe that e)

625+

601626-- | Split the event into an 'EventSelector' that allows efficient selection of

602627-- the individual 'Event's.

603628fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)

@@ -650,7 +675,7 @@ zipDynWith f da db =

650675 in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec

651676

652677instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

653− mconcat = fmap (mconcat . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]

678+ mconcat = distributeListOverDynWith mconcat

654679 mempty = constDyn mempty

655680 mappend = zipDynWith mappend

656681

@@ -669,6 +694,15 @@ distributeDMapOverDynPure dm = case DMap.toList dm of

669694 return $ DMap.unionWithKey (\_ _ new -> new) olds news

670695 in result

671696

697+-- | Convert a list of 'Dynamic's into a 'Dynamic' list.

698+distributeListOverDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]

699+distributeListOverDyn = distributeListOverDynWith id

700+

701+-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's

702+distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b

703+distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]

704+

705+

672706--------------------------------------------------------------------------------

673707-- Accumulator

674708--------------------------------------------------------------------------------

src/Reflex/Deletable/Class.hsnew file+17

@@ -0,0 +1,17 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE FunctionalDependencies #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE UndecidableInstances #-}

5+module Reflex.Deletable.Class where

7+import Reflex.Class

9+import Control.Monad.Reader

10+import Control.Monad.Trans.Control

11+

12+class (Reflex t, Monad m) => Deletable t m | m -> t where

13+ deletable :: Event t () -> m a -> m a

14+

15+instance Deletable t m => Deletable t (ReaderT r m) where

16+ {-# INLINABLE deletable #-}

17+ deletable = liftThrough . deletable

src/Reflex/Dynamic.hs+18

@@ -59,9 +59,11 @@ module Reflex.Dynamic

5959 , distributeDMapOverDyn

6060 , distributeFHListOverDyn

6161 , forDyn

62+ , forDynM

6263 , getDemuxed

6364 , joinDyn

6465 , mapDyn

66+ , mapDynM

6567 , mconcatDyn

6668 , nubDyn

6769 , splitDyn

@@ -438,11 +440,27 @@ instance IsHList (a, b, c, d, e, f) where

438440mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)

439441mapDyn f = return . fmap f

440442

443+-- | Map a sampling function over a 'Dynamic'. The sampling function will use the input 'Dynamic''s 'current' 'Behavior' until the first time its 'updated' 'Event' fires, at which point it will be invoked only once each time the 'Event' fires.

444+{-# DEPRECATED mapDynM "Consider using the Monad instance for Dynamic instead." #-}

445+mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)

446+mapDynM f d = do

447+ let e' = push (fmap Just . f :: a -> PushM t (Maybe b)) $ updated d

448+ eb' = fmap constant e'

449+ v0 = pull $ f =<< sample (current d)

450+ bb' :: Behavior t (Behavior t b) <- hold v0 eb'

451+ let b' = pull $ sample =<< sample bb'

452+ return $ unsafeDynamic b' e'

453+

441454-- | Flipped version of 'mapDyn'.

442455{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-}

443456forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)

444457forDyn a = return . ffor a

445458

459+-- | Flipped version of 'mapDynM'

460+{-# DEPRECATED forDynM "Consider using the Monad instance for Dynamic instead." #-}

461+forDynM :: forall t m a b. (Reflex t, MonadHold t m) => Dynamic t a -> (forall m'. MonadSample t m' => a -> m' b) -> m (Dynamic t b)

462+forDynM d f = mapDynM f d

463+

446464-- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value

447465-- of the tuple.

448466{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-}

src/Reflex/Dynamic/TH.hs+1−1

@@ -38,7 +38,7 @@ qDyn qe = do

3838 let exprs = reverse exprsReversed

3939 arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs

4040 param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs

41− [| return $ $(return $ LamE [param] e') $ distributeFHListOverDynPure $(return arg) |]

41+ [| return $ $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]

4242

4343-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a

4444-- 'qDyn' quotation.

src/Reflex/DynamicWriter.hsnew file+181

@@ -0,0 +1,181 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FunctionalDependencies #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE RecursiveDo #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+module Reflex.DynamicWriter where

13+

14+import Control.Monad.Exception

15+import Control.Monad.IO.Class

16+import Control.Monad.Reader

17+import Control.Monad.Ref

18+import Control.Monad.State.Strict

19+import Data.Dependent.Map (DMap)

20+import Data.Functor.Compose

21+import Data.Functor.Misc

22+import Data.Map (Map)

23+import qualified Data.Map as Map

24+import Data.Semigroup

25+import Reflex.Class

26+import Reflex.Deletable.Class

27+import Reflex.Dynamic

28+import Reflex.PerformEvent.Class

29+import Reflex.PostBuild.Class

30+import Reflex.Host.Class

31+

32+instance MonadTrans (DynamicWriterT t w) where

33+ lift = DynamicWriterT . lift

34+

35+data PatchMap a where

36+ PatchMap :: Ord k => Map k (Maybe v) -> PatchMap (Map k v)

37+

38+instance Patch PatchMap where

39+ apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

40+ where insertions = Map.mapMaybeWithKey (const id) p

41+ deletions = Map.mapMaybeWithKey (const nothingToJust) p

42+ nothingToJust = \case

43+ Nothing -> Just ()

44+ Just _ -> Nothing

45+

46+instance Ord k => Semigroup (PatchMap (Map k v)) where

47+ PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map

48+ -- PatchMap is idempotent, so stimes n is id for every n

49+#if MIN_VERSION_semigroups(0,17,0)

50+ stimes = stimesIdempotentMonoid

51+#else

52+ times1p n x = case compare n 0 of

53+ LT -> error "stimesIdempotentMonoid: negative multiplier"

54+ EQ -> mempty

55+ GT -> x

56+#endif

57+

58+instance Ord k => Monoid (PatchMap (Map k v)) where

59+ mempty = PatchMap mempty

60+ mappend = (<>)

61+

62+mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map k v)) -> m (Dynamic t v)

63+mconcatIncremental m0 e = do

64+ d <- foldDynMaybe apply m0 e

65+ return $ fmap (mconcat . Map.elems) d

66+

67+mapIncrementalMapValuesWithKey :: Reflex t => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')

68+mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m

69+

70+mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')

71+mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f

72+

73+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'

74+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a

75+

76+incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)

77+incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m

78+

79+mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)

80+mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap

81+

82+holdIncrementalReplaceableMap :: forall t k v m. (MonadFix m, MonadHold t m, Reflex t, Ord k) => Map k (Replaceable t v) -> Event t (PatchMap (Map k (Replaceable t v))) -> m (Incremental t PatchMap (Map k v))

83+holdIncrementalReplaceableMap m0 m' = do

84+ rec vals <- holdIncremental m0 $ m' <> valChanges

85+ let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals

86+ return $ mapIncrementalMapValues _replaceable_value vals

87+

88+mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)

89+mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

90+ where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a

91+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m

92+

93+data Replaceable t w = Replaceable

94+ { _replaceable_value :: w

95+ , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored

96+ }

97+

98+type DynamicWriterAccumulator t w = [Replaceable t (Dynamic t w)]

99+

100+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT (DynamicWriterAccumulator t w) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order

101+

102+instance MonadRef m => MonadRef (DynamicWriterT t w m) where

103+ type Ref (DynamicWriterT t w m) = Ref m

104+ newRef = lift . newRef

105+ readRef = lift . readRef

106+ writeRef r = lift . writeRef r

107+

108+instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where

109+ atomicModifyRef r = lift . atomicModifyRef r

110+

111+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where

112+ newEventWithTrigger = lift . newEventWithTrigger

113+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

114+

115+runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)

116+runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []

117+

118+mconcatIncrementalReplaceableDynMap :: forall m t k v. (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k) => Map k (Replaceable t (Dynamic t v)) -> Event t (PatchMap (Map k (Replaceable t (Dynamic t v)))) -> Event t () -> m (Replaceable t (Dynamic t v))

119+mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do

120+ rec vals <- holdIncremental m0 $ m' <> valChanges

121+ let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals

122+ let i = mapIncrementalMapValues _replaceable_value vals

123+ noMoreAdditions <- holdDyn False $ True <$ additionsCeased

124+ let replaceSelf nma x = do

125+ guard nma

126+ case Map.toList x of

127+ [] -> return Nothing -- Delete self

128+ [(_, n)] -> return $ Just n --TODO: What if this one is also replacing itself simultaneously?

129+ _ -> mzero

130+ result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i

131+ return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals

132+

133+runDynamicWriterT :: (MonadFix m, Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)

134+runDynamicWriterT (DynamicWriterT a) = do

135+ (result, ws) <- runStateT a []

136+ Replaceable w _ <- mconcatIncrementalReplaceableDynMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never never

137+ return (result, w)

138+

139+class Monad m => MonadDynamicWriter t w m | m -> t w where

140+ tellDyn :: Dynamic t w -> m ()

141+

142+instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where

143+ tellDyn w = DynamicWriterT $ modify (Replaceable w never :)

144+

145+instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where

146+ ask = lift ask

147+ local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a

148+ reader = lift . reader

149+

150+liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)

151+liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do

152+ s <- get

153+ (b, (a, newS)) <- lift $ f $ runStateT child s

154+ put newS

155+ return (b, a)

156+

157+instance (Deletable t m, Reflex t, Monoid w, MonadHold t m, MonadFix m) => Deletable t (DynamicWriterT t w m) where

158+ deletable delete child = do

159+ (result, output) <- lift $ deletable delete $ runDynamicWriterT child

160+ DynamicWriterT $ modify (Replaceable output (Nothing <$ delete) :)

161+ return result

162+

163+instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

164+ type Performable (DynamicWriterT t w m) = Performable m

165+ performEvent_ = lift . performEvent_

166+ performEvent = lift . performEvent

167+

168+instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where

169+ newTriggerEvent = lift newTriggerEvent

170+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

171+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

172+

173+instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where

174+ getPostBuild = lift getPostBuild

175+

176+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where

177+ tellDyn = lift . tellDyn

178+

179+instance MonadState s m => MonadState s (DynamicWriterT t w m) where

180+ get = lift get

181+ put = lift . put

src/Reflex/PerformEvent/Base.hsnew file+168

@@ -0,0 +1,168 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE RecursiveDo #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE StandaloneDeriving #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeOperators #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+module Reflex.PerformEvent.Base where

13+

14+import Reflex.Class

15+import Reflex.Deletable.Class

16+import Reflex.Host.Class

17+import Reflex.PerformEvent.Class

18+

19+import Control.Lens

20+import Control.Monad.Exception

21+import Control.Monad.Identity

22+import Control.Monad.Ref

23+import Control.Monad.State.Strict

24+import Data.Align

25+import Data.Dependent.Map (DMap)

26+import qualified Data.Dependent.Map as DMap

27+import Data.Dependent.Sum

28+import Data.Functor.Compose

29+import Data.Functor.Misc

30+import Data.Maybe

31+import Data.Semigroup

32+import Data.These

33+import Data.Word

34+

35+newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }

36+

37+newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?

38+

39+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: StateT [Event t (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())] (HostFrame t) a }

40+

41+deriving instance ReflexHost t => Functor (PerformEventT t m)

42+deriving instance ReflexHost t => Applicative (PerformEventT t m)

43+deriving instance ReflexHost t => Monad (PerformEventT t m)

44+deriving instance ReflexHost t => MonadFix (PerformEventT t m)

45+deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)

46+deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)

47+

48+instance (ReflexHost t, MonadAsyncException (HostFrame t)) => MonadAsyncException (PerformEventT t m) where

49+ mask f = PerformEventT $ mask $ \unmask -> unPerformEventT $ f $ PerformEventT . unmask . unPerformEventT

50+

51+instance (ReflexHost t, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => PerformEvent t (PerformEventT t m) where

52+ type Performable (PerformEventT t m) = PerformEventT t m

53+ {-# INLINABLE performEvent_ #-}

54+ performEvent_ = PerformEventT . modify . (:) . fmap (This . (>> return []))

55+ {-# INLINABLE performEvent #-}

56+ performEvent e = PerformEventT $ do

57+ (eResult, reResultTrigger) <- newEventWithTriggerRef

58+ modify $ (:) $ ffor e $ \o -> This $ do

59+ result <- o

60+ return [EventTriggerRef reResultTrigger :=> Identity result]

61+ return eResult

62+

63+instance (ReflexHost t, Monad (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => Deletable t (PerformEventT t m) where

64+ {-# INLINABLE deletable #-}

65+ deletable d a = PerformEventT $ do

66+ (result, reverseEventsToPerform) <- lift $ runStateT (unPerformEventT a) []

67+ let (numberedEvents, _) = numberWith (\n e -> Const2 n :=> e) (reverse reverseEventsToPerform) (1 :: Word64)

68+ eventToPerform <- lift $ mergePerformEventsAndAdd (DMap.fromList numberedEvents) never

69+ modify (align eventToPerform d :)

70+ return result

71+

72+instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

73+ {-# INLINABLE newEventWithTrigger #-}

74+ newEventWithTrigger = PerformEventT . lift . newEventWithTrigger

75+ {-# INLINABLE newFanEventWithTrigger #-}

76+ newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f

77+

78+{-# INLINABLE numberWith #-}

79+numberWith :: (Enum n, Traversable t) => (n -> a -> b) -> t a -> n -> (t b, n)

80+numberWith f t n0 = flip runState n0 $ forM t $ \x -> state $ \n -> (f n x, succ n)

81+

82+{-# INLINABLE mergePerformEventsAndAdd #-}

83+mergePerformEventsAndAdd :: forall t m. ReflexHost t

84+ => DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)

85+ -> Event t (PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)))

86+ -> HostFrame t (Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity]))

87+mergePerformEventsAndAdd initial eAddNew = do

88+ rec events :: Incremental t PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t))

89+ <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings

90+ let event = mergeWith DMap.union [mergeIncremental events, coincidence (fmap (\(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m) eAddNew)]

91+ eventToPerform :: Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity])

92+ eventToPerform = ffor event $

93+ fmap concat .

94+ sequence .

95+ fmapMaybe (\(Const2 _ :=> Identity x) -> x ^? here) .

96+ DMap.toList

97+ eDelete :: Event t (PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)))

98+ eDelete = fforMaybe event $

99+ fmap (PatchDMap . DMap.fromList) .

100+ (\l -> if null l then Nothing else Just l) .

101+ fmapMaybe (\(Const2 k :=> Identity x) -> (Const2 k :=> Compose Nothing) <$ x ^? there) .

102+ DMap.toList

103+ return eventToPerform

104+

105+{-# INLINABLE runPerformEventT #-}

106+runPerformEventT :: forall t m a. (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => PerformEventT t m a -> HostFrame t (a, Event t (HostFrame t [DSum (EventTriggerRef t m) Identity]))

107+runPerformEventT (PerformEventT a) = do

108+ (result, reverseEventsToPerform) <- runStateT a []

109+ (eAddNew, reAddNewTrigger) <- newEventWithTriggerRef

110+ let (numberedEvents, nextNumber) = numberWith (\n e -> Const2 n :=> e) (reverse reverseEventsToPerform) (1 :: Word64)

111+ nextNumberRef <- newRef nextNumber

112+ let runResult :: PerformEventT t m [DSum (EventTriggerRef t m) Identity] -> HostFrame t [DSum (EventTriggerRef t m) Identity]

113+ runResult (PerformEventT r) = do

114+ (followups, reverseNewEventsToPerform) <- runStateT r []

115+ oldN <- readRef nextNumberRef

116+ let (numberedNewEvents, newN) = numberWith (\n e -> Const2 n :=> Compose (Just e)) (reverse reverseNewEventsToPerform) oldN

117+ if newN == oldN then return followups else do

118+ writeRef nextNumberRef newN

119+ return $ (EventTriggerRef reAddNewTrigger :=> Identity (PatchDMap (DMap.fromList numberedNewEvents))) : followups

120+ eventToPerform <- mergePerformEventsAndAdd (DMap.fromList numberedEvents) eAddNew

121+ return (result, runResult <$> eventToPerform)

122+

123+{-# INLINABLE hostPerformEventT #-}

124+hostPerformEventT :: forall t m a. (Monad m, MonadSubscribeEvent t m, MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => PerformEventT t m a -> m (a, FireCommand t m)

125+hostPerformEventT a = do

126+ (result, eventToPerform) <- runHostFrame $ runPerformEventT a

127+ eventToPerformHandle <- subscribeEvent eventToPerform

128+ return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do

129+ let go :: [DSum (EventTrigger t) Identity] -> m [a']

130+ go ts = do

131+ (result', mToPerform) <- fireEventsAndRead ts $ do

132+ mToPerform <- sequence =<< readEvent eventToPerformHandle

133+ result' <- readPhase

134+ return (result', mToPerform)

135+ case mToPerform of

136+ Nothing -> return [result']

137+ Just toPerform -> do

138+ followupEventTriggerRefs <- runHostFrame toPerform

139+ followupEventTriggers <- forM followupEventTriggerRefs $ \(EventTriggerRef rt :=> x) -> do

140+ mt <- readRef rt

141+ return $ fmap (:=> x) mt

142+ fmap (result':) $ go $ catMaybes followupEventTriggers

143+ go triggers

144+

145+instance ReflexHost t => MonadSample t (PerformEventT t m) where

146+ {-# INLINABLE sample #-}

147+ sample = PerformEventT . lift . sample

148+

149+instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where

150+ {-# INLINABLE hold #-}

151+ hold v0 v' = PerformEventT $ lift $ hold v0 v'

152+ {-# INLINABLE holdDyn #-}

153+ holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'

154+ {-# INLINABLE holdIncremental #-}

155+ holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'

156+

157+instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where

158+ type Ref (PerformEventT t m) = Ref (HostFrame t)

159+ {-# INLINABLE newRef #-}

160+ newRef = PerformEventT . lift . newRef

161+ {-# INLINABLE readRef #-}

162+ readRef = PerformEventT . lift . readRef

163+ {-# INLINABLE writeRef #-}

164+ writeRef r = PerformEventT . lift . writeRef r

165+

166+instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where

167+ {-# INLINABLE atomicModifyRef #-}

168+ atomicModifyRef r = PerformEventT . lift . atomicModifyRef r

src/Reflex/PerformEvent/Class.hsnew file+46

@@ -0,0 +1,46 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FunctionalDependencies #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+module Reflex.PerformEvent.Class where

11+

12+import Reflex.Class

13+

14+import Control.Monad.Reader

15+

16+class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where

17+ type Performable m :: * -> *

18+ performEvent :: Event t (Performable m a) -> m (Event t a)

19+ performEvent_ :: Event t (Performable m ()) -> m ()

20+

21+--TODO: Shouldn't have IO hard-coded

22+class Monad m => TriggerEvent t m | m -> t where

23+ newTriggerEvent :: m (Event t a, a -> IO ())

24+ newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow

25+ newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)

26+

27+{-# INLINABLE performEventAsync #-}

28+performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)

29+performEventAsync e = do

30+ (eOut, triggerEOut) <- newTriggerEvent

31+ performEvent_ $ fmap ($ triggerEOut) e

32+ return eOut

33+

34+instance PerformEvent t m => PerformEvent t (ReaderT r m) where

35+ type Performable (ReaderT r m) = ReaderT r (Performable m)

36+ performEvent_ e = do

37+ r <- ask

38+ lift $ performEvent_ $ flip runReaderT r <$> e

39+ performEvent e = do

40+ r <- ask

41+ lift $ performEvent $ flip runReaderT r <$> e

42+

43+instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where

44+ newTriggerEvent = lift newTriggerEvent

45+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

46+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

src/Reflex/PostBuild/Class.hsnew file+91

@@ -0,0 +1,91 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FunctionalDependencies #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+module Reflex.PostBuild.Class where

11+

12+import Control.Monad.Exception

13+import Control.Monad.Reader

14+import Control.Monad.Ref

15+import Control.Monad.Trans.Control

16+import Reflex.Class

17+import Reflex.Deletable.Class

18+import Reflex.Host.Class

19+import Reflex.PerformEvent.Class

20+

21+class (Reflex t, Monad m) => PostBuild t m | m -> t where

22+ getPostBuild :: m (Event t ())

23+

24+newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

25+

26+instance MonadTransControl (PostBuildT t) where

27+ type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a

28+ {-# INLINABLE liftWith #-}

29+ liftWith = defaultLiftWith PostBuildT unPostBuildT

30+ {-# INLINABLE restoreT #-}

31+ restoreT = defaultRestoreT PostBuildT

32+

33+instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where

34+ {-# INLINABLE getPostBuild #-}

35+ getPostBuild = PostBuildT ask

36+

37+instance Deletable t m => Deletable t (PostBuildT t m) where

38+ {-# INLINABLE deletable #-}

39+ deletable = liftThrough . deletable

40+

41+instance MonadSample t m => MonadSample t (PostBuildT t m) where

42+ {-# INLINABLE sample #-}

43+ sample = lift . sample

44+

45+instance MonadHold t m => MonadHold t (PostBuildT t m) where

46+ {-# INLINABLE hold #-}

47+ hold v0 = lift . hold v0

48+ {-# INLINABLE holdDyn #-}

49+ holdDyn v0 = lift . holdDyn v0

50+ {-# INLINABLE holdIncremental #-}

51+ holdIncremental v0 = lift . holdIncremental v0

52+

53+instance PerformEvent t m => PerformEvent t (PostBuildT t m) where

54+ type Performable (PostBuildT t m) = PostBuildT t (Performable m)

55+ {-# INLINABLE performEvent_ #-}

56+ performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e

57+ {-# INLINABLE performEvent #-}

58+ performEvent e = liftWith $ \run -> performEvent $ fmap run e

59+

60+instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where

61+ {-# INLINABLE newEventWithTrigger #-}

62+ newEventWithTrigger = PostBuildT . lift . newEventWithTrigger

63+ {-# INLINABLE newFanEventWithTrigger #-}

64+ newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f

65+

66+instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where

67+ {-# INLINABLE newTriggerEvent #-}

68+ newTriggerEvent = lift newTriggerEvent

69+ {-# INLINABLE newTriggerEventWithOnComplete #-}

70+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

71+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

72+

73+instance MonadRef m => MonadRef (PostBuildT t m) where

74+ type Ref (PostBuildT t m) = Ref m

75+ {-# INLINABLE newRef #-}

76+ newRef = lift . newRef

77+ {-# INLINABLE readRef #-}

78+ readRef = lift . readRef

79+ {-# INLINABLE writeRef #-}

80+ writeRef r = lift . writeRef r

81+

82+instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where

83+ {-# INLINABLE atomicModifyRef #-}

84+ atomicModifyRef r = lift . atomicModifyRef r

85+

86+{-# INLINABLE runPostBuildT #-}

87+runPostBuildT :: PostBuildT t m a -> Event t () -> m a

88+runPostBuildT (PostBuildT a) = runReaderT a

89+

90+instance PostBuild t m => PostBuild t (ReaderT r m) where

91+ getPostBuild = lift getPostBuild

src/Reflex/Spider.hs+13−6

@@ -1,10 +1,17 @@

11-- | This module exports all of the user-facing functionality of the 'Spider'

22-- 'Reflex' engine

3−module Reflex.Spider ( Spider

4− , SpiderEnv

5− , Global

6− , SpiderHost

7− , runSpiderHost

8− ) where

3+module Reflex.Spider

4+ ( Spider

5+ , SpiderTimeline

6+ , Global

7+ , SpiderHost

8+ , runSpiderHost

9+ , runSpiderHostForTimeline

10+ , newSpiderTimeline

11+ , withSpiderTimeline

12+ , askSpiderTimeline

13+ -- * Deprecated

14+ , SpiderEnv

15+ ) where

916

1017import Reflex.Spider.Internal

src/Reflex/Spider/Internal.hs+104−97

@@ -20,16 +20,7 @@

2020{-# LANGUAGE UndecidableInstances #-}

2121-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

2222-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

23−module Reflex.Spider.Internal

24− ( Spider

25− , SpiderEnv (..)

26− , Global

27− , SpiderHost

28− , runSpiderHost

29− , newSpiderEnv

30− , askSpiderEnv

31− , SpiderEventHandle

32− ) where

23+module Reflex.Spider.Internal where

3324

3425import Control.Applicative

3526import Control.Concurrent

@@ -691,7 +682,7 @@ data Hold x p a

691682 }

692683

693684data EventEnv x

694− = EventEnv { eventEnvSpiderEnv :: !(SpiderEnv x)

685+ = EventEnv { eventEnvSpiderTimeline :: !(SpiderTimeline x)

695686 , eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

696687 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe

697688 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

@@ -750,17 +741,17 @@ instance HasCurrentHeight x (EventM x) where

750741 delayedRef <- asks eventEnvDelayedMerges

751742 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [DelayedMerge subscribed]

752743

753−class HasSpiderEnv x m | m -> x where

754− -- | Retrieve the current SpiderEnv

755− askSpiderEnv :: m (SpiderEnv x)

744+class HasSpiderTimeline x m | m -> x where

745+ -- | Retrieve the current SpiderTimeline

746+ askSpiderTimeline :: m (SpiderTimeline x)

756747

757−instance HasSpiderEnv x (EventM x) where

758− {-# INLINE askSpiderEnv #-}

759− askSpiderEnv = EventM $ asks eventEnvSpiderEnv

748+instance HasSpiderTimeline x (EventM x) where

749+ {-# INLINE askSpiderTimeline #-}

750+ askSpiderTimeline = EventM $ asks eventEnvSpiderTimeline

760751

761−instance HasSpiderEnv x (SpiderHost x) where

762− {-# INLINE askSpiderEnv #-}

763− askSpiderEnv = SpiderHost ask

752+instance HasSpiderTimeline x (SpiderHost x) where

753+ {-# INLINE askSpiderTimeline #-}

754+ askSpiderTimeline = SpiderHost ask

764755

765756putCurrentHeight :: Height -> EventM x ()

766757putCurrentHeight h = EventM $ do

@@ -811,7 +802,7 @@ hold v0 e = do

811802 return h

812803

813804{-# INLINE getHoldEventSubscription #-}

814−getHoldEventSubscription :: forall m p a x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, R.Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderEnv x m, m ~ EventM x) => Hold x p a -> m (EventSubscription x (p a))

805+getHoldEventSubscription :: forall m p a x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, R.Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x m, m ~ EventM x) => Hold x p a -> m (EventSubscription x (p a))

815806getHoldEventSubscription h = do

816807 ep <- liftIO $ readIORef $ holdParent h

817808 case ep of

@@ -1182,8 +1173,8 @@ coincidence a = eventCoincidence $ Coincidence

11821173run :: [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

11831174run roots after = do

11841175 tracePropagate $ "Running an event frame with " <> show (length roots) <> " events"

1185− spiderEnv <- SpiderHost ask

1186− result <- SpiderHost $ lift $ withMVar (_spiderEnv_lock spiderEnv) $ \_ -> flip runReaderT spiderEnv $ unSpiderHost $ runFrame $ do

1176+ spiderTimeline <- SpiderHost ask

1177+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock spiderTimeline) $ \_ -> flip runReaderT spiderTimeline $ unSpiderHost $ runFrame $ do

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

11881179 occBefore <- liftIO $ do

11891180 occBefore <- readIORef occRef

@@ -1249,17 +1240,17 @@ type WeakList a = [Weak a]

12491240#ifdef DEBUG

12501241withIncreasedDepth :: CanTrace x m => m a -> m a

12511242withIncreasedDepth a = do

1252− spiderEnv <- askSpiderEnv

1253− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) succ

1243+ spiderTimeline <- askSpiderTimeline

1244+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

12541245 result <- a

1255− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) pred

1246+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

12561247 return result

12571248#else

12581249withIncreasedDepth :: m a -> m a

12591250withIncreasedDepth = id

12601251#endif

12611252

1262−type CanTrace x m = (HasSpiderEnv x m, MonadIO m)

1253+type CanTrace x m = (HasSpiderTimeline x m, MonadIO m)

12631254

12641255{-# INLINE tracePropagate #-}

12651256tracePropagate :: (CanTrace x m) => String -> m ()

@@ -1278,8 +1269,8 @@ traceMWhen :: (CanTrace x m) => Bool -> m String -> m ()

12781269traceMWhen b getMessage = when b $ do

12791270 message <- getMessage

12801271#ifdef DEBUG

1281− spiderEnv <- askSpiderEnv

1282− d <- liftIO $ readIORef $ _spiderEnv_depth spiderEnv

1272+ spiderTimeline <- askSpiderTimeline

1273+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

12831274#else

12841275 let d = 0

12851276#endif

@@ -1360,7 +1351,7 @@ zeroRef :: IORef Height

13601351zeroRef = unsafePerformIO $ newIORef zeroHeight

13611352

13621353type CanSubscribe x m =

1363− ( HasSpiderEnv x m

1354+ ( HasSpiderTimeline x m

13641355 , HasCurrentHeight x m

13651356 , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state

13661357 , Defer SomeClear m -- Wiping out event firings

@@ -1530,7 +1521,7 @@ subscribeMergeSubscribed :: MergeSubscribed x k -> Subscriber x (DMap k Identity

15301521subscribeMergeSubscribed subscribed sub = WeakBag.insert sub (mergeSubscribedSubscribers subscribed) (mergeSubscribedWeakSelf subscribed) cleanupMergeSubscribed

15311522

15321523{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket (Subscriber x a), FanSubscribed x k, Maybe a) #-}

1533−getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderEnv x m, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), FanSubscribed x k, Maybe a)

1524+getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x m, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), FanSubscribed x k, Maybe a)

15341525getFanSubscribed k f sub = do

15351526 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

15361527 case mSubscribed of

@@ -1589,7 +1580,7 @@ subscribeFanSubscribed k subscribed sub = do

15891580 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

15901581

15911582{-# SPECIALIZE getSwitchSubscribed :: Switch x a -> Subscriber x a -> EventM x (WeakBagTicket (Subscriber x a), SwitchSubscribed x a, Maybe a) #-}

1592−getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderEnv x m, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), SwitchSubscribed x a, Maybe a)

1583+getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderTimeline x m, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), SwitchSubscribed x a, Maybe a)

15931584getSwitchSubscribed s sub = do

15941585 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

15951586 case mSubscribed of

@@ -1645,7 +1636,7 @@ subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO (WeakB

16451636subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

16461637

16471638{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket (Subscriber x a), CoincidenceSubscribed x a, Maybe a) #-}

1648−getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderEnv x m, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), CoincidenceSubscribed x a, Maybe a)

1639+getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x m, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket (Subscriber x a), CoincidenceSubscribed x a, Maybe a)

16491640getCoincidenceSubscribed c sub = do

16501641 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

16511642 case mSubscribed of

@@ -1738,9 +1729,9 @@ initMerge (SomeMergeInit subscribed changed) = do

17381729

17391730-- | Run an event action outside of a frame

17401731runFrame :: forall x a. EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

1741−runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

1732+runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do

17421733 -- Clear out pending unsubscriptions; these will need to happen eventually anyway, and might cause us a lot of extra work during the frame, so get rid of them now

1743− pendingCleanups <- atomicModifyIORef (_spiderEnv_cleanups spiderEnv) $ \x -> ([], x)

1734+ pendingCleanups <- atomicModifyIORef (_spiderTimeline_cleanups spiderTimeline) $ \x -> ([], x)

17441735 {-# SCC "cleanups" #-} sequence_ pendingCleanups

17451736 toAssignRef <- newIORef [] -- This should only actually get used when events are firing

17461737 holdInitRef <- newIORef []

@@ -1751,7 +1742,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

17511742 toClearRootRef <- newIORef []

17521743 coincidenceInfosRef <- newIORef []

17531744 delayedRef <- liftIO $ newIORef IntMap.empty

1754− let env = EventEnv spiderEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef

1745+ let env = EventEnv spiderTimeline toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef

17551746 let go = do

17561747 result <- a

17571748 runHoldInits holdInitRef mergeInitRef -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events

@@ -1808,7 +1799,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

18081799 runEventM (runHoldInits holdInitRef mergeInitRef) env --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant

18091800 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

18101801 sub <- newSubscriberSwitch subscribed

1811− subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderEnv --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient

1802+ subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderTimeline --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient

18121803 {-

18131804 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

18141805 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

@@ -1963,64 +1954,68 @@ invalidate toReconnectRef wis = do

19631954--------------------------------------------------------------------------------

19641955

19651956-- | The default, global Spider environment

1966−type Spider = SpiderEnv Global

1957+type Spider = SpiderTimeline Global

19671958

19681959-- | Designates the default, global Spider timeline

19691960data Global

19701961

1971−{-# NOINLINE globalSpiderEnv #-}

1972−globalSpiderEnv :: SpiderEnv Global

1973−globalSpiderEnv = unsafePerformIO unsafeNewSpiderEnv

1962+{-# NOINLINE globalSpiderTimeline #-}

1963+globalSpiderTimeline :: SpiderTimeline Global

1964+globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline

19741965

19751966-- | Stores all global data relevant to a particular Spider timeline; only one

19761967-- value should exist for each type @x@

1977−data SpiderEnv x = SpiderEnv

1978− { _spiderEnv_toUnsubscribe :: !(IORef [SomeEventSubscription x])

1979− , _spiderEnv_lock :: !(MVar ())

1980− , _spiderEnv_cleanups :: !(IORef [IO ()])

1968+data SpiderTimeline x = SpiderTimeline

1969+ { _spiderTimeline_toUnsubscribe :: !(IORef [SomeEventSubscription x])

1970+ , _spiderTimeline_lock :: !(MVar ())

1971+ , _spiderTimeline_cleanups :: !(IORef [IO ()])

19811972#ifdef DEBUG

1982− , _spiderEnv_depth :: !(IORef Int)

1973+ , _spiderTimeline_depth :: !(IORef Int)

19831974#endif

19841975 }

1985−type role SpiderEnv nominal

1976+type role SpiderTimeline nominal

19861977

1987−instance GEq SpiderEnv where

1988− a `geq` b = if _spiderEnv_lock a == _spiderEnv_lock b

1989− then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderEnv can't have two different 'x' arguments

1978+instance GEq SpiderTimeline where

1979+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

1980+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimeline can't have two different 'x' arguments

19901981 else Nothing

19911982

1992−unsafeNewSpiderEnv :: forall x. IO (SpiderEnv x)

1993−unsafeNewSpiderEnv = do

1983+unsafeNewSpiderTimeline :: forall x. IO (SpiderTimeline x)

1984+unsafeNewSpiderTimeline = do

19941985 toUnsubscribe <- newIORef []

19951986 lock <- newMVar ()

19961987 cleanups <- newIORef []

19971988#ifdef DEBUG

19981989 depthRef <- newIORef 0

19991990#endif

2000− return $ SpiderEnv

2001− { _spiderEnv_toUnsubscribe = toUnsubscribe

2002− , _spiderEnv_lock = lock

2003− , _spiderEnv_cleanups = cleanups

1991+ return $ SpiderTimeline

1992+ { _spiderTimeline_toUnsubscribe = toUnsubscribe

1993+ , _spiderTimeline_lock = lock

1994+ , _spiderTimeline_cleanups = cleanups

20041995#ifdef DEBUG

2005− , _spiderEnv_depth = depthRef

1996+ , _spiderTimeline_depth = depthRef

20061997#endif

20071998 }

20081999

2009−-- | Create a new SpiderEnv

2010−newSpiderEnv :: IO (Some SpiderEnv)

2011−newSpiderEnv = Some.This <$> unsafeNewSpiderEnv

2000+-- | Create a new SpiderTimeline

2001+newSpiderTimeline :: IO (Some SpiderTimeline)

2002+newSpiderTimeline = withSpiderTimeline (pure . Some.This)

2003+

2004+-- | Pass a new timeline to the given function.

2005+withSpiderTimeline :: (forall x. SpiderTimeline x -> IO r) -> IO r

2006+withSpiderTimeline k = unsafeNewSpiderTimeline >>= k

20122007

20132008newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

20142009

20152010newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

20162011

2017−instance R.Reflex (SpiderEnv x) where

2018− newtype Behavior (SpiderEnv x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2019− newtype Event (SpiderEnv x) a = SpiderEvent { unSpiderEvent :: Event x a }

2020− newtype Dynamic (SpiderEnv x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x Identity a } deriving (Functor, Applicative, Monad)

2021− newtype Incremental (SpiderEnv x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic x p a }

2022− type PullM (SpiderEnv x) = SpiderPullM x

2023− type PushM (SpiderEnv x) = SpiderPushM x

2012+instance R.Reflex (SpiderTimeline x) where

2013+ newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2014+ newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2015+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x Identity a } deriving (Functor, Applicative, Monad)

2016+ newtype Incremental (SpiderTimeline x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic x p a }

2017+ type PullM (SpiderTimeline x) = SpiderPullM x

2018+ type PushM (SpiderTimeline x) = SpiderPushM x

20242019 {-# INLINABLE never #-}

20252020 never = SpiderEvent eventNever

20262021 {-# INLINABLE constant #-}

@@ -2030,13 +2025,13 @@ instance R.Reflex (SpiderEnv x) where

20302025 {-# INLINABLE pull #-}

20312026 pull = SpiderBehavior . pull . coerce

20322027 {-# INLINABLE merge #-}

2033− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderEnv x)) -> DMap k (Event x))

2028+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))

20342029 {-# INLINABLE fan #-}

20352030 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

20362031 {-# INLINABLE switch #-}

2037− switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderEnv x) a) -> Behavior x (Event x a)) . unSpiderBehavior

2032+ switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior

20382033 {-# INLINABLE coincidence #-}

2039− coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderEnv x) a) -> Event x (Event x a)) . unSpiderEvent

2034+ coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent

20402035 {-# INLINABLE current #-}

20412036 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

20422037 {-# INLINABLE updated #-}

@@ -2046,7 +2041,7 @@ instance R.Reflex (SpiderEnv x) where

20462041 {-# INLINABLE unsafeBuildIncremental #-}

20472042 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv

20482043 {-# INLINABLE mergeIncremental #-}

2049− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x R.PatchDMap (DMap k (R.Event (SpiderEnv x))) -> Dynamic x R.PatchDMap (DMap k (Event x))) . unSpiderIncremental

2044+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x R.PatchDMap (DMap k (R.Event (SpiderTimeline x))) -> Dynamic x R.PatchDMap (DMap k (Event x))) . unSpiderIncremental

20502045 {-# INLINABLE currentIncremental #-}

20512046 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

20522047 {-# INLINABLE updatedIncremental #-}

@@ -2056,11 +2051,11 @@ instance R.Reflex (SpiderEnv x) where

20562051 c <- readBehaviorUntracked $ dynamicCurrent i

20572052 return $ Identity <$> R.apply p c --TODO: Avoid the redundant 'apply'

20582053

2059−instance R.MonadSample (SpiderEnv x) (EventM x) where

2054+instance R.MonadSample (SpiderTimeline x) (EventM x) where

20602055 {-# INLINABLE sample #-}

20612056 sample (SpiderBehavior b) = readBehaviorUntracked b

20622057

2063−instance R.MonadHold (SpiderEnv x) (EventM x) where

2058+instance R.MonadHold (SpiderTimeline x) (EventM x) where

20642059 {-# INLINABLE hold #-}

20652060 hold = holdSpiderEventM

20662061 {-# INLINABLE holdDyn #-}

@@ -2068,16 +2063,16 @@ instance R.MonadHold (SpiderEnv x) (EventM x) where

20682063 {-# INLINABLE holdIncremental #-}

20692064 holdIncremental = holdIncrementalSpiderEventM

20702065

2071−holdSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Behavior (SpiderEnv x) a)

2066+holdSpiderEventM :: a -> R.Event (SpiderTimeline x) a -> EventM x (R.Behavior (SpiderTimeline x) a)

20722067holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

20732068

2074−holdDynSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Dynamic (SpiderEnv x) a)

2069+holdDynSpiderEventM :: a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)

20752070holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

20762071

2077−holdIncrementalSpiderEventM :: R.Patch p => a -> R.Event (SpiderEnv x) (p a) -> EventM x (R.Incremental (SpiderEnv x) p a)

2072+holdIncrementalSpiderEventM :: R.Patch p => a -> R.Event (SpiderTimeline x) (p a) -> EventM x (R.Incremental (SpiderTimeline x) p a)

20782073holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e

20792074

2080−instance R.MonadHold (SpiderEnv x) (SpiderHost x) where

2075+instance R.MonadHold (SpiderTimeline x) (SpiderHost x) where

20812076 {-# INLINABLE hold #-}

20822077 hold v0 e = R.runHostFrame $ R.hold v0 e

20832078 {-# INLINABLE holdDyn #-}

@@ -2085,19 +2080,19 @@ instance R.MonadHold (SpiderEnv x) (SpiderHost x) where

20852080 {-# INLINABLE holdIncremental #-}

20862081 holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e

20872082

2088−instance R.MonadSample (SpiderEnv x) (SpiderHost x) where

2083+instance R.MonadSample (SpiderTimeline x) (SpiderHost x) where

20892084 {-# INLINABLE sample #-}

20902085 sample = runFrame . readBehaviorUntracked . unSpiderBehavior

20912086

2092−instance R.MonadSample (SpiderEnv x) (SpiderPullM x) where

2087+instance R.MonadSample (SpiderTimeline x) (SpiderPullM x) where

20932088 {-# INLINABLE sample #-}

20942089 sample = coerce . readBehaviorTracked . unSpiderBehavior

20952090

2096−instance R.MonadSample (SpiderEnv x) (SpiderPushM x) where

2091+instance R.MonadSample (SpiderTimeline x) (SpiderPushM x) where

20972092 {-# INLINABLE sample #-}

20982093 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

20992094

2100−instance R.MonadHold (SpiderEnv x) (SpiderPushM x) where

2095+instance R.MonadHold (SpiderTimeline x) (SpiderPushM x) where

21012096 {-# INLINABLE hold #-}

21022097 hold v0 e = R.current <$> R.holdDyn v0 e

21032098 {-# INLINABLE holdDyn #-}

@@ -2112,7 +2107,7 @@ data SpiderEventHandle x a = SpiderEventHandle

21122107 , spiderEventHandleValue :: IORef (Maybe a)

21132108 }

21142109

2115−instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHostFrame x) where

2110+instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

21162111 {-# INLINABLE subscribeEvent #-}

21172112 subscribeEvent e = SpiderHostFrame $ do

21182113 --TODO: Unsubscribe eventually (manually and/or with weak ref)

@@ -2129,12 +2124,12 @@ instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHostFrame x) where

21292124 , spiderEventHandleValue = val

21302125 }

21312126

2132−instance R.ReflexHost (SpiderEnv x) where

2133− type EventTrigger (SpiderEnv x) = RootTrigger x

2134− type EventHandle (SpiderEnv x) = SpiderEventHandle x

2135− type HostFrame (SpiderEnv x) = SpiderHostFrame x

2127+instance R.ReflexHost (SpiderTimeline x) where

2128+ type EventTrigger (SpiderTimeline x) = RootTrigger x

2129+ type EventHandle (SpiderTimeline x) = SpiderEventHandle x

2130+ type HostFrame (SpiderTimeline x) = SpiderHostFrame x

21362131

2137−instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where

2132+instance R.MonadReadEvent (SpiderTimeline x) (ReadPhase x) where

21382133 {-# NOINLINE readEvent #-}

21392134 readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do

21402135 result <- readIORef $ spiderEventHandleValue h

@@ -2155,7 +2150,7 @@ instance MonadAtomicRef (EventM x) where

21552150 atomicModifyRef r f = liftIO $ atomicModifyRef r f

21562151

21572152-- | The monad for actions that manipulate a Spider timeline identified by @x@

2158−newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2153+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimeline x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

21592154

21602155instance Monad (SpiderHost x) where

21612156 {-# INLINABLE (>>=) #-}

@@ -2170,7 +2165,12 @@ instance Monad (SpiderHost x) where

21702165-- | Run an action affecting the global Spider timeline; this will be guarded by

21712166-- a mutex for that timeline

21722167runSpiderHost :: SpiderHost Global a -> IO a

2173−runSpiderHost (SpiderHost a) = runReaderT a globalSpiderEnv

2168+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimeline

2169+

2170+-- | Run an action affecting a given Spider timeline; this will be guarded by a

2171+-- mutex for that timeline

2172+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimeline x -> IO a

2173+runSpiderHostForTimeline (SpiderHost a) = runReaderT a

21742174

21752175newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

21762176

@@ -2184,10 +2184,10 @@ instance Monad (SpiderHostFrame x) where

21842184 {-# INLINABLE fail #-}

21852185 fail s = SpiderHostFrame $ fail s

21862186

2187−instance R.MonadSample (SpiderEnv x) (SpiderHostFrame x) where

2187+instance R.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

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

21892189

2190−instance R.MonadHold (SpiderEnv x) (SpiderHostFrame x) where

2190+instance R.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

21912191 {-# INLINABLE hold #-}

21922192 hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

21932193 {-# INLINABLE holdDyn #-}

@@ -2211,29 +2211,29 @@ newFanEventWithTriggerIO f = do

22112211 }

22122212 return $ EventSelector $ \k -> eventRoot k r

22132213

2214−instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHost x) where

2214+instance R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

22152215 newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO

22162216 newFanEventWithTrigger f = SpiderHost $ lift $ do

22172217 es <- newFanEventWithTriggerIO f

22182218 return $ R.EventSelector $ SpiderEvent . select es

22192219

2220−instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHostFrame x) where

2220+instance R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

22212221 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

22222222 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

22232223 es <- newFanEventWithTriggerIO f

22242224 return $ R.EventSelector $ SpiderEvent . select es

22252225

2226−instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHost x) where

2226+instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where

22272227 {-# INLINABLE subscribeEvent #-}

22282228 subscribeEvent = runFrame . runSpiderHostFrame . R.subscribeEvent

22292229

22302230newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)

22312231

2232−instance R.MonadSample (SpiderEnv x) (ReadPhase x) where

2232+instance R.MonadSample (SpiderTimeline x) (ReadPhase x) where

22332233 {-# INLINABLE sample #-}

22342234 sample = ReadPhase . R.sample

22352235

2236−instance R.MonadHold (SpiderEnv x) (ReadPhase x) where

2236+instance R.MonadHold (SpiderTimeline x) (ReadPhase x) where

22372237 {-# INLINABLE hold #-}

22382238 hold v0 e = ReadPhase $ R.hold v0 e

22392239 {-# INLINABLE holdDyn #-}

@@ -2241,7 +2241,7 @@ instance R.MonadHold (SpiderEnv x) (ReadPhase x) where

22412241 {-# INLINABLE holdIncremental #-}

22422242 holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e

22432243

2244−instance R.MonadReflexHost (SpiderEnv x) (SpiderHost x) where

2244+instance R.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where

22452245 type ReadPhase (SpiderHost x) = ReadPhase x

22462246 fireEventsAndRead es (ReadPhase a) = run es a

22472247 runHostFrame = runFrame . runSpiderHostFrame

@@ -2263,3 +2263,10 @@ instance MonadRef (SpiderHostFrame x) where

22632263

22642264instance MonadAtomicRef (SpiderHostFrame x) where

22652265 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r

2266+

2267+--------------------------------------------------------------------------------

2268+-- Deprecated items

2269+--------------------------------------------------------------------------------

2270+

2271+{-# DEPRECATED SpiderEnv "Use 'SpiderTimeline' instead" #-}

2272+type SpiderEnv = SpiderTimeline