54db66f · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Merge remote-tracking branch 'ryantrinkle/inlining' into HEAD

54db66fRyan Trinkle10 years ago

default.nix+5−5

compare with develop

unifiedsplit

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

1{ mkDerivation, base, bifunctors, containers, deepseq

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

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

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

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

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

5+, semigroups, split, stdenv, stm, syb, template-haskell

6−, transformers-compat

6+, these, transformers, transformers-compat, prim-uniq

7}:

8mkDerivation {

9 pname = "reflex";

10 version = "0.5.0";

11− src = ./.;

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

12 libraryHaskellDepends = [

13 base bifunctors containers dependent-map dependent-sum

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

17+ transformers-compat prim-uniq

18 ];

19 testHaskellDepends = [

20 base bifunctors containers deepseq dependent-map dependent-sum

reflex.cabal+1−1

@@ -29,6 +29,7 @@ library

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

30 mtl >= 2.1 && < 2.3,

31 primitive >= 0.5 && < 0.7,

32+ prim-uniq >= 0.1.0.1 && < 0.2,

32 ref-tf == 0.4.*,

33 ref-tf == 0.4.*,

33 semigroupoids >= 4.0 && < 6,

34 semigroupoids >= 4.0 && < 6,

34 semigroups >= 0.16 && < 0.19,

35 semigroups >= 0.16 && < 0.19,

@@ -44,7 +45,6 @@ library

44 Data.WeakBag,

45 Data.WeakBag,

45 Reflex,

46 Reflex,

46 Reflex.Class,

47 Reflex.Class,

47− Reflex.Deletable.Class,

48 Reflex.Dynamic,

49 Reflex.Dynamic.TH,

50 Reflex.Dynamic.Uniq,

src/Data/Functor/Misc.hs+1

@@ -20,6 +20,7 @@ module Data.Functor.Misc

20 , WrapArg (..)

21 -- * Convenience functions for DMap

22 , mapWithFunctorToDMap

23+ , mapKeyValuePairsMonotonic

23 , combineDMapsWithKey

24 , combineDMapsWithKey

24 -- * Deprecated functions

25 -- * Deprecated functions

25 , sequenceDmap

26 , sequenceDmap

src/Reflex/Class.hs+41

@@ -26,6 +26,7 @@ module Reflex.Class

26 -- ** 'Incremental'-related types

27 , Patch (..)

28 , PatchDMap (..)

29+ , PatchMap (..)

29 -- * Convenience functions

30 -- * Convenience functions

30 , constDyn

31 , constDyn

31 , pushAlways

32 , pushAlways

@@ -80,6 +81,7 @@ module Reflex.Class

80 , ffilter

81 , ffilter

81 -- * Miscellaneous convenience functions

82 -- * Miscellaneous convenience functions

82 , ffor

83 , ffor

84+ , MonadAdjust (..)

83 -- * Deprecated functions

85 -- * Deprecated functions

84 , appendEvents

86 , appendEvents

85 , onceE

87 , onceE

@@ -111,6 +113,7 @@ import Data.GADT.Compare ((:~:) (..), GEq (..))

111import Data.GADT.Show (GShow (..))

113import Data.GADT.Show (GShow (..))

112import Data.List.NonEmpty (NonEmpty (..))

114import Data.List.NonEmpty (NonEmpty (..))

113import Data.Map (Map)

115import Data.Map (Map)

116+import qualified Data.Map as Map

114import Data.Maybe

117import Data.Maybe

115import Data.Monoid hiding (Alt, (<>))

118import Data.Monoid hiding (Alt, (<>))

116import Data.Semigroup (Semigroup, sconcat, stimes, stimesIdempotentMonoid, (<>))

119import Data.Semigroup (Semigroup, sconcat, stimes, stimesIdempotentMonoid, (<>))

@@ -240,6 +243,33 @@ instance Patch PatchDMap where

240 Nothing -> Just $ Constant ()

243 Nothing -> Just $ Constant ()

241 Just _ -> Nothing

244 Just _ -> Nothing

242

245

246+data PatchMap a where

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

248+

249+instance Patch PatchMap where

250+ 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?

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

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

253+ nothingToJust = \case

254+ Nothing -> Just ()

255+ Just _ -> Nothing

256+

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

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

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

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

261+ stimes = stimesIdempotentMonoid

262+#else

263+ times1p n x = case compare n 0 of

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

265+ EQ -> mempty

266+ GT -> x

267+#endif

268+

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

270+ mempty = PatchMap mempty

271+ mappend = (<>)

272+

243-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'

273-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'

244-- _must_ change when and only when the 'Event' fires, such that the

274-- _must_ change when and only when the 'Event' fires, such that the

245-- 'Behavior''s value is always equal to the most recent firing of the 'Event';

275-- 'Behavior''s value is always equal to the most recent firing of the 'Event';

@@ -789,6 +819,17 @@ zipListWithEvent f l e = do

789 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?

819 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?

790 mapAccumMaybe_ f' l e

820 mapAccumMaybe_ f' l e

791

821

822+class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

823+ sequenceDMapWithAdjust :: GCompare k => DMap k m -> Event t (PatchDMap (DMap k m)) -> m (DMap k Identity, Event t (PatchDMap (DMap k Identity)))

824+

825+instance (Reflex t, MonadAdjust t m) => MonadAdjust t (ReaderT r m) where

826+ sequenceDMapWithAdjust dm0 dm' = do

827+ r <- ask

828+ let loweredDm0 = DMap.map (`runReaderT` r) dm0

829+ loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

830+ DMap.map (\(Compose mv) -> Compose $ fmap (`runReaderT` r) mv) p

831+ lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

832+

792--------------------------------------------------------------------------------

833--------------------------------------------------------------------------------

793-- Deprecated functions

834-- Deprecated functions

794--------------------------------------------------------------------------------

835--------------------------------------------------------------------------------

src/Reflex/Deletable/Class.hsdeleted−17

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

1−{-# LANGUAGE FlexibleInstances #-}

2−{-# LANGUAGE FunctionalDependencies #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE UndecidableInstances #-}

5−module Reflex.Deletable.Class where

6−

7−import Reflex.Class

8−

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/DynamicWriter.hs+56−41

@@ -12,18 +12,21 @@

12module Reflex.DynamicWriter where

14import Control.Monad.Exception

15+import Control.Monad.Identity

15import Control.Monad.IO.Class

16import Control.Monad.IO.Class

16import Control.Monad.Reader

17import Control.Monad.Reader

17import Control.Monad.Ref

18import Control.Monad.Ref

18import Control.Monad.State.Strict

19import Control.Monad.State.Strict

19−import Data.Dependent.Map (DMap)

20+import Data.Dependent.Map (DMap, DSum (..))

21+import Data.Foldable

20import Data.Functor.Compose

22import Data.Functor.Compose

21import Data.Functor.Misc

23import Data.Functor.Misc

22import Data.Map (Map)

24import Data.Map (Map)

23import qualified Data.Map as Map

25import qualified Data.Map as Map

24import Data.Semigroup

26import Data.Semigroup

27+import Data.Some (Some)

28+import qualified Data.Some as Some

25import Reflex.Class

29import Reflex.Class

26−import Reflex.Deletable.Class

27import Reflex.Dynamic

30import Reflex.Dynamic

28import Reflex.PerformEvent.Class

31import Reflex.PerformEvent.Class

29import Reflex.PostBuild.Class

32import Reflex.PostBuild.Class

@@ -32,33 +35,6 @@ import Reflex.Host.Class

32instance MonadTrans (DynamicWriterT t w) where

35instance MonadTrans (DynamicWriterT t w) where

33 lift = DynamicWriterT . lift

36 lift = DynamicWriterT . lift

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−

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

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

63mconcatIncremental m0 e = do

39mconcatIncremental m0 e = do

64 d <- foldDynMaybe apply m0 e

40 d <- foldDynMaybe apply m0 e

@@ -95,7 +71,7 @@ data Replaceable t w = Replaceable

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

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

96 }

72 }

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

74+type DynamicWriterAccumulator t w = [Dynamic t w]

100newtype 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

76newtype 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

@@ -115,7 +91,12 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWrit

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

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

116runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []

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

94+mconcatIncrementalReplaceableDynMap :: forall m t k v.

95+ (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k)

96+ => Map k (Replaceable t (Dynamic t v))

97+ -> Event t (PatchMap (Map k (Replaceable t (Dynamic t v))))

98+ -> Event t ()

99+ -> m (Replaceable t (Dynamic t v))

119mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do

100mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do

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

101 rec vals <- holdIncremental m0 $ m' <> valChanges

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

102 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals

@@ -130,17 +111,16 @@ mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do

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

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

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

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

132

113

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

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

134runDynamicWriterT (DynamicWriterT a) = do

115runDynamicWriterT (DynamicWriterT a) = do

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

116 (result, ws) <- runStateT a []

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

137− return (result, w)

117+ return (result, mconcat $ reverse ws)

138

118

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

119class Monad m => MonadDynamicWriter t w m | m -> t w where

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

120 tellDyn :: Dynamic t w -> m ()

141

121

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

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

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

123+ tellDyn w = DynamicWriterT $ modify (w :)

144

124

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

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

146 ask = lift ask

126 ask = lift ask

@@ -154,12 +134,6 @@ liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do

154 put newS

134 put newS

155 return (b, a)

135 return (b, a)

156

136

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−

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

137instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

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

138 type Performable (DynamicWriterT t w m) = Performable m

165 performEvent_ = lift . performEvent_

139 performEvent_ = lift . performEvent_

@@ -179,3 +153,44 @@ instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where

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

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

180 get = lift get

154 get = lift get

181 put = lift . put

155 put = lift . put

156+

157+newtype DynamicWriterTLoweredResult t w v = DynamicWriterTLoweredResult { unDynamicWriterTLoweredResult :: (v, Dynamic t w) }

158+

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

160+ sequenceDMapWithAdjust (dm0 :: DMap k (DynamicWriterT t w m)) dm' = do

161+ let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap DynamicWriterTLoweredResult (runDynamicWriterT v)) dm0

162+ let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

163+ mapKeyValuePairsMonotonic (\(k :=> Compose mv) -> WrapArg k :=> Compose (fmap (fmap DynamicWriterTLoweredResult . runDynamicWriterT) mv)) p

164+ (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

165+ let getValue (DynamicWriterTLoweredResult (v, _)) = v

166+ getWritten (DynamicWriterTLoweredResult (_, w)) = w

167+ liftedResult0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> k :=> Identity (getValue r)) result0

168+ liftedResult' = ffor result' $ \(PatchDMap p) -> PatchDMap $

169+ mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mr) -> k :=> Compose (fmap (Identity . getValue . runIdentity) mr)) p

170+ liftedWritten0 :: DMap (Const2 (Some k) (Dynamic t w)) Identity

171+ liftedWritten0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> Const2 (Some.This k) :=> Identity (getWritten r)) result0

172+ liftedWritten' = ffor result' $ \(PatchDMap p) -> PatchDMap $

173+ mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mr) -> Const2 (Some.This k) :=> Compose (fmap (Identity . getWritten . runIdentity) mr)) p

174+ --TODO: We should be able to improve the performance here in two ways

175+ -- 1. Incrementally merging the Dynamics

176+ -- 2. Incrementally updating the mconcat of the merged Dynamics

177+ i <- holdIncremental liftedWritten0 liftedWritten'

178+ tellDyn $ join $ fold . dmapToMap <$> incrementalToDynamic i

179+ return (liftedResult0, liftedResult')

180+

181+withDynamicWriterT :: (Monoid w, Reflex t, MonadHold t m, MonadFix m)

182+ => (w -> w')

183+ -> DynamicWriterT t w m a

184+ -> DynamicWriterT t w' m a

185+withDynamicWriterT f dw = do

186+ (r, d) <- lift $ do

187+ (r, d) <- runDynamicWriterT dw

188+ let d' = fmap f d

189+ return (r, d')

190+ tellDyn d

191+ return r

192+

193+instance MonadRequest t m => MonadRequest t (DynamicWriterT t w m) where

194+ type Request (DynamicWriterT t w m) = Request m

195+ type Response (DynamicWriterT t w m) = Response m

196+ withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f

src/Reflex/PerformEvent/Base.hs+199−78

@@ -1,7 +1,10 @@

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE PartialTypeSignatures #-}

7+{-# LANGUAGE PolyKinds #-}

5{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RecursiveDo #-}

9{-# LANGUAGE RecursiveDo #-}

7{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

@@ -12,31 +15,36 @@

12module Reflex.PerformEvent.Base where

15module Reflex.PerformEvent.Base where

14import Reflex.Class

17import Reflex.Class

15−import Reflex.Deletable.Class

16import Reflex.Host.Class

18import Reflex.Host.Class

19+import Reflex.PostBuild.Class

17import Reflex.PerformEvent.Class

20import Reflex.PerformEvent.Class

19import Control.Lens

22import Control.Lens

20import Control.Monad.Exception

23import Control.Monad.Exception

21import Control.Monad.Identity

24import Control.Monad.Identity

25+import Control.Monad.Primitive

22import Control.Monad.Ref

26import Control.Monad.Ref

23import Control.Monad.State.Strict

27import Control.Monad.State.Strict

24−import Data.Align

28+import Control.Monad.Reader

29+import Data.Coerce

25−import Data.Dependent.Map (DMap)

30+import Data.Dependent.Map (DMap, GCompare (..), Some)

26import qualified Data.Dependent.Map as DMap

31import qualified Data.Dependent.Map as DMap

27import Data.Dependent.Sum

32import Data.Dependent.Sum

28import Data.Functor.Compose

33import Data.Functor.Compose

29import Data.Functor.Misc

34import Data.Functor.Misc

30−import Data.Maybe

31import Data.Semigroup

35import Data.Semigroup

36+import qualified Data.Some as Some

32import Data.These

37import Data.These

33−import Data.Word

38+import Data.Tuple

39+import Data.Unique.Tag

40+

41+import Unsafe.Coerce

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

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

37newtype 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?

45newtype 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?

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

47+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequestT t (HostFrame t) Identity (HostFrame t) a }

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

49deriving instance ReflexHost t => Functor (PerformEventT t m)

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

50deriving instance ReflexHost t => Applicative (PerformEventT t m)

@@ -45,29 +53,25 @@ deriving instance ReflexHost t => MonadFix (PerformEventT t m)

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

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

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

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

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

56+instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where

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

57+ type PrimState (PerformEventT t m) = PrimState (HostFrame t)

58+ primitive = PerformEventT . lift . primitive

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

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

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

61+ type Performable (PerformEventT t m) = HostFrame t

53 {-# INLINABLE performEvent_ #-}

62 {-# INLINABLE performEvent_ #-}

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

63+ performEvent_ = PerformEventT . requesting_

55 {-# INLINABLE performEvent #-}

64 {-# INLINABLE performEvent #-}

56− performEvent e = PerformEventT $ do

65+ performEvent = PerformEventT . fmap (fmap runIdentity) . requesting

57− (eResult, reResultTrigger) <- newEventWithTriggerRef

66+

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

67+instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where

64− {-# INLINABLE deletable #-}

68+ sequenceDMapWithAdjust outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequestTWith f (coerce outerDm0) (unsafeCoerce outerDm') --TODO: Eliminate unsafeCoerce (why doesn't coerce work here, even inside the Event and PatchDMap?)

65− deletable d a = PerformEventT $ do

69+ where f :: DMap k (HostFrame t) -> Event t (PatchDMap (DMap k (HostFrame t))) -> RequestT t (HostFrame t) Identity (HostFrame t) (DMap k Identity, Event t (PatchDMap (DMap k Identity)))

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

70+ f dm0 dm' = do

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

71+ result0 <- lift $ DMap.traverseWithKey (\_ v -> Identity <$> v) dm0

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

72+ result' <- requesting $ ffor dm' $ \(PatchDMap p) -> do

69− modify (align eventToPerform d :)

73+ PatchDMap <$> DMap.traverseWithKey (\_ (Compose mv) -> Compose <$> mapM (fmap Identity) mv) p

70− return result

74+ return (result0, fmap runIdentity result')

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

76instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

73 {-# INLINABLE newEventWithTrigger #-}

77 {-# INLINABLE newEventWithTrigger #-}

@@ -75,55 +79,19 @@ instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

75 {-# INLINABLE newFanEventWithTrigger #-}

79 {-# INLINABLE newFanEventWithTrigger #-}

76 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f

80 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f

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

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

83+hostPerformEventT :: forall t m a.

84+ ( Monad m

85+ , MonadSubscribeEvent t m

86+ , MonadReflexHost t m

87+ , MonadRef m

88+ , Ref m ~ Ref IO

89+ )

90+ => PerformEventT t m a

91+ -> m (a, FireCommand t m)

125hostPerformEventT a = do

92hostPerformEventT a = do

93+ (response, responseTrigger) <- newEventWithTriggerRef

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

94+ (result, eventToPerform) <- runHostFrame $ runRequestT (unPerformEventT a) response

127 eventToPerformHandle <- subscribeEvent eventToPerform

95 eventToPerformHandle <- subscribeEvent eventToPerform

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

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

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

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

@@ -135,11 +103,12 @@ hostPerformEventT a = do

135 case mToPerform of

103 case mToPerform of

136 Nothing -> return [result']

104 Nothing -> return [result']

137 Just toPerform -> do

105 Just toPerform -> do

138− followupEventTriggerRefs <- runHostFrame toPerform

106+ responses <- runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform

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

107+ mrt <- readRef responseTrigger

140− mt <- readRef rt

108+ let followupEventTriggers = case mrt of

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

109+ Just rt -> [rt :=> Identity responses]

110+ Nothing -> []

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

111+ (result':) <$> go followupEventTriggers

143 go triggers

112 go triggers

144

113

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

114instance ReflexHost t => MonadSample t (PerformEventT t m) where

@@ -166,3 +135,155 @@ instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m)

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

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

167 {-# INLINABLE atomicModifyRef #-}

136 {-# INLINABLE atomicModifyRef #-}

168 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r

137 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r

138+

139+--------------------------------------------------------------------------------

140+-- RequestT

141+--------------------------------------------------------------------------------

142+

143+newtype RequestT t request response m a

144+ = RequestT { unRequestT :: StateT [Event t (DMap (Tag (PrimState m)) request)] (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }

145+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)

146+

147+instance MonadTrans (RequestT t request response) where

148+ lift = RequestT . lift . lift

149+

150+runRequestT :: forall t m a request response.

151+ ( Reflex t

152+ , Monad m

153+ )

154+ => RequestT t request response m a

155+ -> Event t (DMap (Tag (PrimState m)) response)

156+ -> m (a, Event t (DMap (Tag (PrimState m)) request))

157+runRequestT (RequestT a) responses = do

158+ (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

159+ return (result, mergeWith DMap.union requests)

160+

161+instance (Reflex t, PrimMonad m) => MonadRequest t (RequestT t request response m) where

162+ type Request (RequestT t request response m) = request

163+ type Response (RequestT t request response m) = response

164+ withRequesting a = do

165+ t <- lift newTag

166+ s <- RequestT ask

167+ (req, result) <- a $ select s $ WrapArg t

168+ RequestT $ modify $ (:) $ DMap.singleton t <$> req

169+ return result

170+

171+data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)

172+

173+mapPatchKeysAndValuesMonotonic :: GCompare k' => (forall a. DMapTransform a k k' v v') -> PatchDMap (DMap k v) -> PatchDMap (DMap k' v')

174+mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> Compose mv) -> case x of DMapTransform f g -> f k :=> Compose (fmap g mv)) p

175+

176+mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'

177+mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of

178+ DMapTransform f g -> f k :=> g v

179+

180+instance MonadSample t m => MonadSample t (RequestT t request response m) where

181+ sample = lift . sample

182+

183+instance MonadHold t m => MonadHold t (RequestT t request response m) where

184+ hold v0 = lift . hold v0

185+ holdDyn v0 = lift . holdDyn v0

186+ holdIncremental v0 = lift . holdIncremental v0

187+

188+instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequestT t request response m) where

189+ sequenceDMapWithAdjust = sequenceDMapWithAdjustRequestTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'

190+

191+sequenceDMapWithAdjustRequestTWith :: (GCompare k, Monad m, Reflex t, MonadHold t m)

192+ => (forall k'. GCompare k'

193+ => DMap k' m

194+ -> Event t (PatchDMap (DMap k' m))

195+ -> RequestT t request response m (DMap k' Identity, Event t (PatchDMap (DMap k' Identity)))

196+ )

197+ -> DMap k (RequestT t request response m)

198+ -> Event t (PatchDMap (DMap k (RequestT t request response m)))

199+ -> RequestT t request response m (DMap k Identity, Event t (PatchDMap (DMap k Identity)))

200+sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response m)) dm' = do

201+ response <- RequestT ask

202+ let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t (DMap (Tag (PrimState m)) request)]) k) (RequestT t request response m) m

203+ inputTransform = DMapTransform WrapArg (\(RequestT v) -> swap <$> runReaderT (runStateT v mempty) response)

204+ (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'

205+ let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

206+ result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

207+ mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mv) -> k :=> Compose (fmap (Identity . snd . runIdentity) mv)) p

208+ requests0 :: DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)

209+ requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mergeWith DMap.union r) children0

210+ requests' :: Event t (PatchDMap (DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)))

211+ requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $

212+ mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mv) -> Const2 (Some.This k) :=> Compose (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p

213+ childRequestMap <- holdIncremental requests0 requests'

214+ RequestT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->

215+ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m

216+-- RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> Compose me) -> me -- We could make it prompt like this, but this seems to be slower than just delaying the PostBuild event to allow this stuff to settle (which is more similar to the previous behavior anyway)

217+ return (result0, result')

218+

219+instance PerformEvent t m => PerformEvent t (RequestT t request response m) where

220+ type Performable (RequestT t request response m) = Performable m

221+ performEvent_ = lift . performEvent_

222+ performEvent = lift . performEvent

223+

224+instance PostBuild t m => PostBuild t (RequestT t request response m) where

225+ getPostBuild = lift getPostBuild

226+

227+instance TriggerEvent t m => TriggerEvent t (RequestT t request response m) where

228+ newTriggerEvent = lift newTriggerEvent

229+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

230+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

231+

232+instance MonadReader r m => MonadReader r (RequestT t request response m) where

233+ ask = lift ask

234+ local f (RequestT a) = RequestT $ mapStateT (mapReaderT $ local f) a

235+ reader = lift . reader

236+

237+{-

238+withRequestT :: forall t m a (req :: * -> *) (req' :: * -> *).

239+ (Reflex t, MonadHold t m, MonadFix m)

240+ => (forall x. request x -> request' x)

241+ -> (forall x. response' x -> response x)

242+ -> RequestT t request response m a

243+ -> RequestT t request' response m a

244+withRequestT f g m = RequestT $ hoist (hoist (withDynamicWriterT f')) (unRequestT m)

245+ where

246+ f' :: Event t [(y, Some request)] -> Event t [(y, Some request')]

247+ f' = fmap . fmap . fmap $ \(SomeRequest req) -> SomeRequest $ f req

248+-}

249+

250+instance MonadRef m => MonadRef (RequestT t request response m) where

251+ type Ref (RequestT t request response m) = Ref m

252+ newRef = lift . newRef

253+ readRef = lift . readRef

254+ writeRef r = lift . writeRef r

255+

256+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequestT t request response m) where

257+ newEventWithTrigger = lift . newEventWithTrigger

258+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

259+

260+

261+--------------------------------------------------------------------------------

262+-- Helpers

263+--------------------------------------------------------------------------------

264+

265+{-# INLINABLE numberWith #-}

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

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

268+

269+{-# INLINABLE mergeSelfDeletingEvents #-}

270+mergeSelfDeletingEvents :: forall t m k v. (Ord k, Reflex t, MonadFix m, MonadHold t m)

271+ => DMap (Const2 k (These v ())) (Event t)

272+ -> Event t (PatchDMap (DMap (Const2 k (These v ())) (Event t)))

273+ -> m (Event t [v])

274+mergeSelfDeletingEvents initial eAddNew = do

275+ rec events :: Incremental t PatchDMap (DMap (Const2 k (These v ())) (Event t))

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

277+ let event = mergeWith DMap.union

278+ [ mergeIncremental events

279+ , coincidence $ ffor eAddNew $ \(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m

280+ ]

281+ eDelete :: Event t (PatchDMap (DMap (Const2 k (These v ())) (Event t)))

282+ eDelete = fforMaybe event $

283+ fmap (PatchDMap . DMap.fromDistinctAscList) .

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

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

286+ DMap.toList

287+ return $ ffor event $

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

289+ DMap.toList

src/Reflex/PerformEvent/Class.hs+46

@@ -11,7 +11,10 @@ module Reflex.PerformEvent.Class where

12import Reflex.Class

14+import Control.Monad.Identity

14import Control.Monad.Reader

15import Control.Monad.Reader

16+import qualified Control.Monad.State.Lazy as Lazy

17+import Control.Monad.State.Strict

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

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

17 type Performable m :: * -> *

20 type Performable m :: * -> *

@@ -24,6 +27,11 @@ class Monad m => TriggerEvent t m | m -> t where

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

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

28 newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)

30+class (Reflex t, Monad m) => MonadRequest t m | m -> t where

31+ type Request m :: * -> *

32+ type Response m :: * -> *

33+ withRequesting :: (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

34+

27{-# INLINABLE performEventAsync #-}

35{-# INLINABLE performEventAsync #-}

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

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

29performEventAsync e = do

37performEventAsync e = do

@@ -44,3 +52,41 @@ instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where

44 newTriggerEvent = lift newTriggerEvent

52 newTriggerEvent = lift newTriggerEvent

45 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

53 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

46 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

54 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

55+

56+instance MonadRequest t m => MonadRequest t (ReaderT r m) where

57+ type Request (ReaderT r m) = Request m

58+ type Response (ReaderT r m) = Response m

59+ withRequesting f = do

60+ r <- ask

61+ lift $ withRequesting $ (`runReaderT` r) . f

62+

63+instance MonadRequest t m => MonadRequest t (StateT s m) where

64+ type Request (StateT s m) = Request m

65+ type Response (StateT s m) = Response m

66+ withRequesting f = do

67+ old <- get

68+ (result, new) <- lift $ withRequesting $ \x -> do

69+ ((request, result), new) <- runStateT (f x) old

70+ return (request, (result, new))

71+ put new

72+ return result

73+

74+instance MonadRequest t m => MonadRequest t (Lazy.StateT s m) where

75+ type Request (Lazy.StateT s m) = Request m

76+ type Response (Lazy.StateT s m) = Response m

77+ withRequesting f = do

78+ old <- Lazy.get

79+ (result, new) <- lift $ withRequesting $ \x -> do

80+ ((request, result), new) <- Lazy.runStateT (f x) old

81+ return (request, (result, new))

82+ Lazy.put new

83+ return result

84+

85+requesting :: MonadRequest t m => Event t (Request m a) -> m (Event t (Response m a))

86+requesting req = withRequesting $ return . (,) req

87+

88+requesting_ :: MonadRequest t m => Event t (Request m a) -> m ()

89+requesting_ req = withRequesting $ \_ -> return (req, ())

90+

91+requestingIdentity :: (MonadRequest t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

92+requestingIdentity = fmap (fmap runIdentity) . requesting

src/Reflex/PostBuild/Class.hs+18−5

@@ -3,6 +3,7 @@

3{-# LANGUAGE FunctionalDependencies #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE RecursiveDo #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeOperators #-}

9{-# LANGUAGE TypeOperators #-}

@@ -10,11 +11,13 @@

10module Reflex.PostBuild.Class where

11module Reflex.PostBuild.Class where

12import Control.Monad.Exception

13import Control.Monad.Exception

14+import Control.Monad.Primitive

13import Control.Monad.Reader

15import Control.Monad.Reader

14import Control.Monad.Ref

16import Control.Monad.Ref

15import Control.Monad.Trans.Control

17import Control.Monad.Trans.Control

18+import qualified Data.Dependent.Map as DMap

19+import Data.Functor.Compose

16import Reflex.Class

20import Reflex.Class

17−import Reflex.Deletable.Class

18import Reflex.Host.Class

21import Reflex.Host.Class

19import Reflex.PerformEvent.Class

22import Reflex.PerformEvent.Class

@@ -23,6 +26,10 @@ class (Reflex t, Monad m) => PostBuild t m | m -> t where

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

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

29+instance PrimMonad m => PrimMonad (PostBuildT x m) where

30+ type PrimState (PostBuildT x m) = PrimState m

31+ primitive = lift . primitive

32+

26instance MonadTransControl (PostBuildT t) where

33instance MonadTransControl (PostBuildT t) where

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

34 type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a

28 {-# INLINABLE liftWith #-}

35 {-# INLINABLE liftWith #-}

@@ -34,10 +41,6 @@ instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where

34 {-# INLINABLE getPostBuild #-}

41 {-# INLINABLE getPostBuild #-}

35 getPostBuild = PostBuildT ask

42 getPostBuild = PostBuildT ask

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

38− {-# INLINABLE deletable #-}

39− deletable = liftThrough . deletable

40−

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

44instance MonadSample t m => MonadSample t (PostBuildT t m) where

42 {-# INLINABLE sample #-}

45 {-# INLINABLE sample #-}

43 sample = lift . sample

46 sample = lift . sample

@@ -89,3 +92,13 @@ runPostBuildT (PostBuildT a) = runReaderT a

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

93instance PostBuild t m => PostBuild t (ReaderT r m) where

91 getPostBuild = lift getPostBuild

94 getPostBuild = lift getPostBuild

95+

96+instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where

97+ sequenceDMapWithAdjust dm0 dm' = do

98+ postBuild <- getPostBuild

99+ let loweredDm0 = DMap.map (`runPostBuildT` postBuild) dm0

100+ rec (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

101+ delayedResult' <- performEvent $ return () <$ result' -- Delaying this result seems to be faster than making RequestT (and thus PerformEvent) more prompt

102+ let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

103+ DMap.map (Compose . fmap (\v -> runPostBuildT v =<< headE (void delayedResult')) . getCompose) p --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence

104+ return (result0, result')

src/Reflex/Spider/Internal.hs+4

@@ -2264,6 +2264,10 @@ instance MonadRef (SpiderHostFrame x) where

2264instance MonadAtomicRef (SpiderHostFrame x) where

2265 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r

2266

2267+instance PrimMonad (SpiderHostFrame x) where

2268+ type PrimState (SpiderHostFrame x) = PrimState IO

2269+ primitive = SpiderHostFrame . EventM . primitive

2270+

2267--------------------------------------------------------------------------------

2271--------------------------------------------------------------------------------

2268-- Deprecated items

2272-- Deprecated items

2269--------------------------------------------------------------------------------

2273--------------------------------------------------------------------------------