f49085a · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Merge branch 'develop' into inlining

f49085aRyan Trinkle10 years ago

default.nix+9−7

compare with develop

unifiedsplit

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

1{ mkDerivation, base, bifunctors, containers, deepseq

2, dependent-map, dependent-sum, exception-transformers

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

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

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

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

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

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

6+, transformers-compat

6}:

7}:

7mkDerivation {

8mkDerivation {

8 pname = "reflex";

9 pname = "reflex";

9− version = "0.4.0";

10+ version = "0.5.0";

10 src = ./.;

11 src = ./.;

11 libraryHaskellDepends = [

12 libraryHaskellDepends = [

12 base bifunctors containers dependent-map dependent-sum

13 base bifunctors containers dependent-map dependent-sum

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

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

14− mtl primitive ref-tf semigroupoids semigroups stm syb

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

15− template-haskell these transformers transformers-compat

16+ semigroups stm syb template-haskell these transformers

17+ transformers-compat

16 ];

18 ];

17 testHaskellDepends = [

19 testHaskellDepends = [

18 base bifunctors containers deepseq dependent-map dependent-sum

20 base bifunctors containers deepseq dependent-map dependent-sum

reflex.cabal+8−1

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

1Name: reflex

2−Version: 0.4.0

2+Version: 0.5.0

3Synopsis: Higher-order Functional Reactive Programming

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

5License: BSD3

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

25 exception-transformers == 0.4.*,

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

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

28+ lens >= 4.7 && < 5,

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

28 mtl >= 2.1 && < 2.3,

30 mtl >= 2.1 && < 2.3,

29 primitive >= 0.5 && < 0.7,

31 primitive >= 0.5 && < 0.7,

30 ref-tf == 0.4.*,

32 ref-tf == 0.4.*,

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

42 Data.WeakBag,

44 Data.WeakBag,

43 Reflex,

45 Reflex,

44 Reflex.Class,

46 Reflex.Class,

47+ Reflex.Deletable.Class,

45 Reflex.Dynamic,

48 Reflex.Dynamic,

46 Reflex.Dynamic.TH,

49 Reflex.Dynamic.TH,

47 Reflex.Dynamic.Uniq,

50 Reflex.Dynamic.Uniq,

51+ Reflex.DynamicWriter,

48 Reflex.Host.Class,

52 Reflex.Host.Class,

53+ Reflex.PerformEvent.Base,

54+ Reflex.PerformEvent.Class,

55+ Reflex.PostBuild.Class,

49 Reflex.Pure,

56 Reflex.Pure,

50 Reflex.Spider,

57 Reflex.Spider,

51 Reflex.Spider.Internal

58 Reflex.Spider.Internal

src/Reflex.hs+3

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

6import Reflex.Dynamic as X

7import Reflex.Dynamic.TH as X

8import 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

9import Reflex.Spider as X

12import Reflex.Spider as X

src/Reflex/Class.hs+35−1

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

36 , mergeWith

37 -- ** Breaking up 'Event's

38 , splitE

39+ , fanEither

40+ , fanThese

39 , fanMap

41 , fanMap

40 , dmapToThese

42 , dmapToThese

41 , EitherTag (..)

43 , EitherTag (..)

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

52 , gate

54 , gate

53 -- ** Combining 'Dynamic's

55 -- ** Combining 'Dynamic's

54 , distributeDMapOverDynPure

56 , distributeDMapOverDynPure

57+ , distributeListOverDyn

58+ , distributeListOverDynWith

55 , zipDyn

59 , zipDyn

56 , zipDynWith

60 , zipDynWith

57 -- ** Accumulating state

61 -- ** Accumulating state

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

63 , zipListWithEvent

67 , zipListWithEvent

64 , headE

68 , headE

65 , tailE

69 , tailE

70+ , headTailE

66 , switcher

71 , switcher

67 -- * Debugging functions

72 -- * Debugging functions

68 , traceEvent

73 , traceEvent

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

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

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

95import qualified Data.Dependent.Map as DMap

100import qualified Data.Dependent.Map as DMap

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

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

102+import Data.Either

97import Data.Foldable

103import Data.Foldable

98import Data.Functor.Bind hiding (join)

104import Data.Functor.Bind hiding (join)

99import qualified Data.Functor.Bind as Bind

105import qualified Data.Functor.Bind as Bind

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

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

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

599mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

605mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

600

606

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+

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

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

602-- the individual 'Event's.

627-- the individual 'Event's.

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

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

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

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

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

651

676

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

677instance (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

654 mempty = constDyn mempty

679 mempty = constDyn mempty

655 mappend = zipDynWith mappend

680 mappend = zipDynWith mappend

656

681

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

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

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

670 in result

695 in result

671

696

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+

672--------------------------------------------------------------------------------

706--------------------------------------------------------------------------------

673-- Accumulator

707-- Accumulator

674--------------------------------------------------------------------------------

708--------------------------------------------------------------------------------

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

59 , distributeDMapOverDyn

60 , distributeFHListOverDyn

61 , forDyn

62+ , forDynM

62 , getDemuxed

63 , getDemuxed

63 , joinDyn

64 , joinDyn

64 , mapDyn

65 , mapDyn

66+ , mapDynM

65 , mconcatDyn

67 , mconcatDyn

66 , nubDyn

68 , nubDyn

67 , splitDyn

69 , splitDyn

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

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

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

439mapDyn f = return . fmap f

441mapDyn f = return . fmap f

440

442

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+

441-- | Flipped version of 'mapDyn'.

454-- | Flipped version of 'mapDyn'.

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

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

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

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

444forDyn a = return . ffor a

457forDyn a = return . ffor a

445

458

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+

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

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

447-- of the tuple.

465-- of the tuple.

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

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

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

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

38 let exprs = reverse exprsReversed

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

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

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

44-- '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 @@

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

2-- 'Reflex' engine

3−module Reflex.Spider ( Spider

3+module Reflex.Spider

4− , SpiderEnv

4+ ( Spider

5+ , SpiderTimeline

5− , Global

6+ , Global

6− , SpiderHost

7+ , SpiderHost

7− , runSpiderHost

8+ , runSpiderHost

9+ , runSpiderHostForTimeline

10+ , newSpiderTimeline

11+ , withSpiderTimeline

12+ , askSpiderTimeline

13+ -- * Deprecated

14+ , SpiderEnv

8− ) where

15+ ) where

10import Reflex.Spider.Internal

17import Reflex.Spider.Internal

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

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

20{-# LANGUAGE UndecidableInstances #-}

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

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

23−module Reflex.Spider.Internal

23+module Reflex.Spider.Internal where

24− ( Spider

25− , SpiderEnv (..)

26− , Global

27− , SpiderHost

28− , runSpiderHost

29− , newSpiderEnv

30− , askSpiderEnv

31− , SpiderEventHandle

32− ) where

34import Control.Applicative

25import Control.Applicative

35import Control.Concurrent

26import Control.Concurrent

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

691 }

682 }

692

683

693data EventEnv x

684data EventEnv x

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

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

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

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

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

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

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

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

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

750 delayedRef <- asks eventEnvDelayedMerges

741 delayedRef <- asks eventEnvDelayedMerges

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

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

752

743

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

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

754− -- | Retrieve the current SpiderEnv

745+ -- | Retrieve the current SpiderTimeline

755− askSpiderEnv :: m (SpiderEnv x)

746+ askSpiderTimeline :: m (SpiderTimeline x)

756

747

757−instance HasSpiderEnv x (EventM x) where

748+instance HasSpiderTimeline x (EventM x) where

758− {-# INLINE askSpiderEnv #-}

749+ {-# INLINE askSpiderTimeline #-}

759− askSpiderEnv = EventM $ asks eventEnvSpiderEnv

750+ askSpiderTimeline = EventM $ asks eventEnvSpiderTimeline

760

751

761−instance HasSpiderEnv x (SpiderHost x) where

752+instance HasSpiderTimeline x (SpiderHost x) where

762− {-# INLINE askSpiderEnv #-}

753+ {-# INLINE askSpiderTimeline #-}

763− askSpiderEnv = SpiderHost ask

754+ askSpiderTimeline = SpiderHost ask

764

755

765putCurrentHeight :: Height -> EventM x ()

756putCurrentHeight :: Height -> EventM x ()

766putCurrentHeight h = EventM $ do

757putCurrentHeight h = EventM $ do

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

811 return h

802 return h

812

803

813{-# INLINE getHoldEventSubscription #-}

804{-# 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))

815getHoldEventSubscription h = do

806getHoldEventSubscription h = do

816 ep <- liftIO $ readIORef $ holdParent h

807 ep <- liftIO $ readIORef $ holdParent h

817 case ep of

808 case ep of

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

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

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

1183run roots after = do

1174run roots after = do

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

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

1185− spiderEnv <- SpiderHost ask

1176+ spiderTimeline <- SpiderHost ask

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

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

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

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

1188 occBefore <- liftIO $ do

1179 occBefore <- liftIO $ do

1189 occBefore <- readIORef occRef

1180 occBefore <- readIORef occRef

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

1249#ifdef DEBUG

1240#ifdef DEBUG

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

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

1251withIncreasedDepth a = do

1242withIncreasedDepth a = do

1252− spiderEnv <- askSpiderEnv

1243+ spiderTimeline <- askSpiderTimeline

1253− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) succ

1244+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

1254 result <- a

1245 result <- a

1255− liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) pred

1246+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

1256 return result

1247 return result

1257#else

1248#else

1258withIncreasedDepth :: m a -> m a

1249withIncreasedDepth :: m a -> m a

1259withIncreasedDepth = id

1250withIncreasedDepth = id

1260#endif

1251#endif

1261

1252

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

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

1263

1254

1264{-# INLINE tracePropagate #-}

1255{-# INLINE tracePropagate #-}

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

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

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

1278traceMWhen b getMessage = when b $ do

1269traceMWhen b getMessage = when b $ do

1279 message <- getMessage

1270 message <- getMessage

1280#ifdef DEBUG

1271#ifdef DEBUG

1281− spiderEnv <- askSpiderEnv

1272+ spiderTimeline <- askSpiderTimeline

1282− d <- liftIO $ readIORef $ _spiderEnv_depth spiderEnv

1273+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

1283#else

1274#else

1284 let d = 0

1275 let d = 0

1285#endif

1276#endif

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

1360zeroRef = unsafePerformIO $ newIORef zeroHeight

1351zeroRef = unsafePerformIO $ newIORef zeroHeight

1361

1352

1362type CanSubscribe x m =

1353type CanSubscribe x m =

1363− ( HasSpiderEnv x m

1354+ ( HasSpiderTimeline x m

1364 , HasCurrentHeight x m

1355 , HasCurrentHeight x m

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

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

1366 , Defer SomeClear m -- Wiping out event firings

1357 , Defer SomeClear m -- Wiping out event firings

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

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

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

1531

1522

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

1523{-# 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)

1534getFanSubscribed k f sub = do

1525getFanSubscribed k f sub = do

1535 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1526 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1536 case mSubscribed of

1527 case mSubscribed of

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

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

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

1590

1581

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

1582{-# 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)

1593getSwitchSubscribed s sub = do

1584getSwitchSubscribed s sub = do

1594 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1585 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1595 case mSubscribed of

1586 case mSubscribed of

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

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

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

1646

1637

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

1638{-# 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)

1649getCoincidenceSubscribed c sub = do

1640getCoincidenceSubscribed c sub = do

1650 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1641 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1651 case mSubscribed of

1642 case mSubscribed of

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

1738

1729

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

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

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

1731runFrame :: 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

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

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

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

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

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

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

1746 holdInitRef <- newIORef []

1737 holdInitRef <- newIORef []

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

1751 toClearRootRef <- newIORef []

1742 toClearRootRef <- newIORef []

1752 coincidenceInfosRef <- newIORef []

1743 coincidenceInfosRef <- newIORef []

1753 delayedRef <- liftIO $ newIORef IntMap.empty

1744 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

1755 let go = do

1746 let go = do

1756 result <- a

1747 result <- a

1757 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

1748 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

1808 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

1799 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

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

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

1810 sub <- newSubscriberSwitch subscribed

1801 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

1812 {-

1803 {-

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

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

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

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

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

1963--------------------------------------------------------------------------------

1954--------------------------------------------------------------------------------

1964

1955

1965-- | The default, global Spider environment

1956-- | The default, global Spider environment

1966−type Spider = SpiderEnv Global

1957+type Spider = SpiderTimeline Global

1967

1958

1968-- | Designates the default, global Spider timeline

1959-- | Designates the default, global Spider timeline

1969data Global

1960data Global

1970

1961

1971−{-# NOINLINE globalSpiderEnv #-}

1962+{-# NOINLINE globalSpiderTimeline #-}

1972−globalSpiderEnv :: SpiderEnv Global

1963+globalSpiderTimeline :: SpiderTimeline Global

1973−globalSpiderEnv = unsafePerformIO unsafeNewSpiderEnv

1964+globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline

1974

1965

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

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

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

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

1977−data SpiderEnv x = SpiderEnv

1968+data SpiderTimeline x = SpiderTimeline

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

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

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

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

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

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

1981#ifdef DEBUG

1972#ifdef DEBUG

1982− , _spiderEnv_depth :: !(IORef Int)

1973+ , _spiderTimeline_depth :: !(IORef Int)

1983#endif

1974#endif

1984 }

1975 }

1985−type role SpiderEnv nominal

1976+type role SpiderTimeline nominal

1986

1977

1987−instance GEq SpiderEnv where

1978+instance GEq SpiderTimeline where

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

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

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

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

1990 else Nothing

1981 else Nothing

1991

1982

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

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

1993−unsafeNewSpiderEnv = do

1984+unsafeNewSpiderTimeline = do

1994 toUnsubscribe <- newIORef []

1985 toUnsubscribe <- newIORef []

1995 lock <- newMVar ()

1986 lock <- newMVar ()

1996 cleanups <- newIORef []

1987 cleanups <- newIORef []

1997#ifdef DEBUG

1988#ifdef DEBUG

1998 depthRef <- newIORef 0

1989 depthRef <- newIORef 0

1999#endif

1990#endif

2000− return $ SpiderEnv

1991+ return $ SpiderTimeline

2001− { _spiderEnv_toUnsubscribe = toUnsubscribe

1992+ { _spiderTimeline_toUnsubscribe = toUnsubscribe

2002− , _spiderEnv_lock = lock

1993+ , _spiderTimeline_lock = lock

2003− , _spiderEnv_cleanups = cleanups

1994+ , _spiderTimeline_cleanups = cleanups

2004#ifdef DEBUG

1995#ifdef DEBUG

2005− , _spiderEnv_depth = depthRef

1996+ , _spiderTimeline_depth = depthRef

2006#endif

1997#endif

2007 }

1998 }

2008

1999

2009−-- | Create a new SpiderEnv

2000+-- | Create a new SpiderTimeline

2010−newSpiderEnv :: IO (Some SpiderEnv)

2001+newSpiderTimeline :: IO (Some SpiderTimeline)

2011−newSpiderEnv = Some.This <$> unsafeNewSpiderEnv

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

2012

2007

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

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

2014

2009

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

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

2016

2011

2017−instance R.Reflex (SpiderEnv x) where

2012+instance R.Reflex (SpiderTimeline x) where

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

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

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

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

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

2015+ newtype Dynamic (SpiderTimeline 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 }

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

2022− type PullM (SpiderEnv x) = SpiderPullM x

2017+ type PullM (SpiderTimeline x) = SpiderPullM x

2023− type PushM (SpiderEnv x) = SpiderPushM x

2018+ type PushM (SpiderTimeline x) = SpiderPushM x

2024 {-# INLINABLE never #-}

2019 {-# INLINABLE never #-}

2025 never = SpiderEvent eventNever

2020 never = SpiderEvent eventNever

2026 {-# INLINABLE constant #-}

2021 {-# INLINABLE constant #-}

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

2030 {-# INLINABLE pull #-}

2025 {-# INLINABLE pull #-}

2031 pull = SpiderBehavior . pull . coerce

2026 pull = SpiderBehavior . pull . coerce

2032 {-# INLINABLE merge #-}

2027 {-# 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))

2034 {-# INLINABLE fan #-}

2029 {-# INLINABLE fan #-}

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

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

2036 {-# INLINABLE switch #-}

2031 {-# 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

2038 {-# INLINABLE coincidence #-}

2033 {-# 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

2040 {-# INLINABLE current #-}

2035 {-# INLINABLE current #-}

2041 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2036 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2042 {-# INLINABLE updated #-}

2037 {-# INLINABLE updated #-}

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

2046 {-# INLINABLE unsafeBuildIncremental #-}

2041 {-# INLINABLE unsafeBuildIncremental #-}

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

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

2048 {-# INLINABLE mergeIncremental #-}

2043 {-# 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

2050 {-# INLINABLE currentIncremental #-}

2045 {-# INLINABLE currentIncremental #-}

2051 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2046 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2052 {-# INLINABLE updatedIncremental #-}

2047 {-# INLINABLE updatedIncremental #-}

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

2056 c <- readBehaviorUntracked $ dynamicCurrent i

2051 c <- readBehaviorUntracked $ dynamicCurrent i

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

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

2058

2053

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

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

2060 {-# INLINABLE sample #-}

2055 {-# INLINABLE sample #-}

2061 sample (SpiderBehavior b) = readBehaviorUntracked b

2056 sample (SpiderBehavior b) = readBehaviorUntracked b

2062

2057

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

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

2064 {-# INLINABLE hold #-}

2059 {-# INLINABLE hold #-}

2065 hold = holdSpiderEventM

2060 hold = holdSpiderEventM

2066 {-# INLINABLE holdDyn #-}

2061 {-# INLINABLE holdDyn #-}

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

2068 {-# INLINABLE holdIncremental #-}

2063 {-# INLINABLE holdIncremental #-}

2069 holdIncremental = holdIncrementalSpiderEventM

2064 holdIncremental = holdIncrementalSpiderEventM

2070

2065

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)

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

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

2073

2068

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)

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

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

2076

2071

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)

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

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

2079

2074

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

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

2081 {-# INLINABLE hold #-}

2076 {-# INLINABLE hold #-}

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

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

2083 {-# INLINABLE holdDyn #-}

2078 {-# INLINABLE holdDyn #-}

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

2085 {-# INLINABLE holdIncremental #-}

2080 {-# INLINABLE holdIncremental #-}

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

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

2087

2082

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

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

2089 {-# INLINABLE sample #-}

2084 {-# INLINABLE sample #-}

2090 sample = runFrame . readBehaviorUntracked . unSpiderBehavior

2085 sample = runFrame . readBehaviorUntracked . unSpiderBehavior

2091

2086

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

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

2093 {-# INLINABLE sample #-}

2088 {-# INLINABLE sample #-}

2094 sample = coerce . readBehaviorTracked . unSpiderBehavior

2089 sample = coerce . readBehaviorTracked . unSpiderBehavior

2095

2090

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

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

2097 {-# INLINABLE sample #-}

2092 {-# INLINABLE sample #-}

2098 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

2093 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

2099

2094

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

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

2101 {-# INLINABLE hold #-}

2096 {-# INLINABLE hold #-}

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

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

2103 {-# INLINABLE holdDyn #-}

2098 {-# INLINABLE holdDyn #-}

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

2112 , spiderEventHandleValue :: IORef (Maybe a)

2107 , spiderEventHandleValue :: IORef (Maybe a)

2113 }

2108 }

2114

2109

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

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

2116 {-# INLINABLE subscribeEvent #-}

2111 {-# INLINABLE subscribeEvent #-}

2117 subscribeEvent e = SpiderHostFrame $ do

2112 subscribeEvent e = SpiderHostFrame $ do

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

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

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

2129 , spiderEventHandleValue = val

2124 , spiderEventHandleValue = val

2130 }

2125 }

2131

2126

2132−instance R.ReflexHost (SpiderEnv x) where

2127+instance R.ReflexHost (SpiderTimeline x) where

2133− type EventTrigger (SpiderEnv x) = RootTrigger x

2128+ type EventTrigger (SpiderTimeline x) = RootTrigger x

2134− type EventHandle (SpiderEnv x) = SpiderEventHandle x

2129+ type EventHandle (SpiderTimeline x) = SpiderEventHandle x

2135− type HostFrame (SpiderEnv x) = SpiderHostFrame x

2130+ type HostFrame (SpiderTimeline x) = SpiderHostFrame x

2136

2131

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

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

2138 {-# NOINLINE readEvent #-}

2133 {-# NOINLINE readEvent #-}

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

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

2140 result <- readIORef $ spiderEventHandleValue h

2135 result <- readIORef $ spiderEventHandleValue h

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

2155 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2150 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2156

2151

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

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

2159

2154

2160instance Monad (SpiderHost x) where

2155instance Monad (SpiderHost x) where

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

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

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

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

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

2171-- a mutex for that timeline

2166-- a mutex for that timeline

2172runSpiderHost :: SpiderHost Global a -> IO a

2167runSpiderHost :: 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

2174

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

2176

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

2184 {-# INLINABLE fail #-}

2185 fail s = SpiderHostFrame $ fail s

2186

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

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

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

2189

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

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

2191 {-# INLINABLE hold #-}

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

2193 {-# INLINABLE holdDyn #-}

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

2211 }

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

2213

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

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

2215 newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO

2216 newFanEventWithTrigger f = SpiderHost $ lift $ do

2217 es <- newFanEventWithTriggerIO f

2218 return $ R.EventSelector $ SpiderEvent . select es

2219

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

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

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

2222 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2223 es <- newFanEventWithTriggerIO f

2224 return $ R.EventSelector $ SpiderEvent . select es

2225

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

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

2227 {-# INLINABLE subscribeEvent #-}

2228 subscribeEvent = runFrame . runSpiderHostFrame . R.subscribeEvent

2229

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

2231

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

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

2233 {-# INLINABLE sample #-}

2234 sample = ReadPhase . R.sample

2235

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

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

2237 {-# INLINABLE hold #-}

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

2239 {-# INLINABLE holdDyn #-}

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

2241 {-# INLINABLE holdIncremental #-}

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

2243

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

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

2245 type ReadPhase (SpiderHost x) = ReadPhase x

2246 fireEventsAndRead es (ReadPhase a) = run es a

2247 runHostFrame = runFrame . runSpiderHostFrame

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

2263

2264instance MonadAtomicRef (SpiderHostFrame x) where

2265 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r

2266+

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

2268+-- Deprecated items

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

2270+

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

2272+type SpiderEnv = SpiderTimeline