58010ed · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Eliminate placeholder/deletable

58010edRyan Trinkle10 years ago

default.nix+3−3

compare with develop

unifiedsplit

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

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

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

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

6−, these, transformers, transformers-compat

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

7}:

8mkDerivation {

9 pname = "reflex";

@@ -13,8 +13,8 @@ mkDerivation {

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

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

@@ -790,6 +820,17 @@ zipListWithEvent f l e = do

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

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

791 mapAccumMaybe_ f' l e

821 mapAccumMaybe_ f' l e

792

822

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

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

825+

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

827+ sequenceDMapWithAdjust dm0 dm' = do

828+ r <- ask

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

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

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

832+ lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

833+

793--------------------------------------------------------------------------------

834--------------------------------------------------------------------------------

794-- Deprecated functions

835-- Deprecated functions

795--------------------------------------------------------------------------------

836--------------------------------------------------------------------------------

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+35−36

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

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

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

154 put newS

135 put newS

155 return (b, a)

136 return (b, a)

156

137

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

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

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

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

165 performEvent_ = lift . performEvent_

140 performEvent_ = lift . performEvent_

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

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

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

180 get = lift get

155 get = lift get

181 put = lift . put

156 put = lift . put

157+

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

159+

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

176+ -- 1. Incrementally merging the Dynamics

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

178+ i <- holdIncremental liftedWritten0 liftedWritten'

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

180+ return (liftedResult0, liftedResult')

src/Reflex/PerformEvent/Base.hs+159−79

@@ -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,35 @@

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

17import Reflex.PerformEvent.Class

19import Reflex.PerformEvent.Class

19import Control.Lens

21import Control.Lens

20import Control.Monad.Exception

22import Control.Monad.Exception

21import Control.Monad.Identity

23import Control.Monad.Identity

24+import Control.Monad.Primitive

22import Control.Monad.Ref

25import Control.Monad.Ref

23import Control.Monad.State.Strict

26import Control.Monad.State.Strict

24−import Data.Align

27+import Control.Monad.Reader

28+import Data.Coerce

25−import Data.Dependent.Map (DMap)

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

26import qualified Data.Dependent.Map as DMap

30import qualified Data.Dependent.Map as DMap

27import Data.Dependent.Sum

31import Data.Dependent.Sum

28import Data.Functor.Compose

32import Data.Functor.Compose

29import Data.Functor.Misc

33import Data.Functor.Misc

30−import Data.Maybe

31import Data.Semigroup

34import Data.Semigroup

35+import qualified Data.Some as Some

32import Data.These

36import Data.These

33−import Data.Word

37+import Data.Tuple

38+import Data.Unique.Tag

39+

40+import Unsafe.Coerce

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

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

44newtype 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 }

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

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

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

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

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

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

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

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

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

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

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

55+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

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

53 {-# INLINABLE performEvent_ #-}

57 {-# INLINABLE performEvent_ #-}

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

58+ performEvent_ = PerformEventT . requesting_

55 {-# INLINABLE performEvent #-}

59 {-# INLINABLE performEvent #-}

56− performEvent e = PerformEventT $ do

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

57− (eResult, reResultTrigger) <- newEventWithTriggerRef

61+

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

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

64− {-# INLINABLE deletable #-}

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

64+ 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) []

65+ f dm0 dm' = do

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

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

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

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

69− modify (align eventToPerform d :)

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

70− return result

69+ return (result0, fmap runIdentity result')

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

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

73 {-# INLINABLE newEventWithTrigger #-}

72 {-# INLINABLE newEventWithTrigger #-}

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

75 {-# INLINABLE newFanEventWithTrigger #-}

74 {-# INLINABLE newFanEventWithTrigger #-}

76 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f

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

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

78+hostPerformEventT :: forall t m a.

79+ ( Monad m

80+ , MonadSubscribeEvent t m

81+ , MonadReflexHost t m

82+ , MonadRef m

83+ , Ref m ~ Ref IO

84+ )

85+ => PerformEventT t m a

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

125hostPerformEventT a = do

87hostPerformEventT a = do

88+ (response, responseTrigger) <- newEventWithTriggerRef

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

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

127 eventToPerformHandle <- subscribeEvent eventToPerform

90 eventToPerformHandle <- subscribeEvent eventToPerform

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

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

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

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

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

135 case mToPerform of

98 case mToPerform of

136 Nothing -> return [result']

99 Nothing -> return [result']

137 Just toPerform -> do

100 Just toPerform -> do

138− followupEventTriggerRefs <- runHostFrame toPerform

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

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

102+ mrt <- readRef responseTrigger

140− mt <- readRef rt

103+ let followupEventTriggers = case mrt of

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

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

105+ Nothing -> []

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

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

143 go triggers

107 go triggers

144

108

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

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

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

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

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

167 {-# INLINABLE atomicModifyRef #-}

131 {-# INLINABLE atomicModifyRef #-}

168 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r

132 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r

133+

134+--------------------------------------------------------------------------------

135+-- RequestT

136+--------------------------------------------------------------------------------

137+

138+newtype RequestT t request response m a

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

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

141+

142+instance MonadTrans (RequestT t request response) where

143+ lift = RequestT . lift . lift

144+

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

146+ ( Reflex t

147+ , Monad m

148+ )

149+ => RequestT t request response m a

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

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

152+runRequestT (RequestT a) responses = do

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

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

155+

156+requesting_ :: (Reflex t, PrimMonad m) => Event t (request a) -> RequestT t request response m ()

157+requesting_ req = do

158+ t <- lift newTag

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

160+

161+withRequesting :: (Reflex t, PrimMonad m) => (Event t (response a) -> RequestT t request response m (Event t (request a), r)) -> RequestT t request response m r

162+withRequesting a = do

163+ t <- lift newTag

164+ s <- RequestT ask

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

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

167+ return result

168+

169+requesting :: (Reflex t, PrimMonad m) => Event t (request a) -> RequestT t request response m (Event t (response a))

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

171+

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

173+

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

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

176+

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

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

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

180+

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

182+ sample = lift . sample

183+

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

185+ hold v0 = lift . hold v0

186+ holdDyn v0 = lift . holdDyn v0

187+ holdIncremental v0 = lift . holdIncremental v0

188+

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

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

191+

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

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

194+ => DMap k' m

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

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

197+ )

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

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

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

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

202+ response <- RequestT ask

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

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

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

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

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

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

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

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

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

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

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

214+ childRequestMap <- holdIncremental requests0 requests'

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

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

217+-- 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)

218+ return (result0, result')

219+

220+--------------------------------------------------------------------------------

221+-- Helpers

222+--------------------------------------------------------------------------------

223+

224+{-# INLINABLE numberWith #-}

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

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

227+

228+{-# INLINABLE mergeSelfDeletingEvents #-}

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

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

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

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

233+mergeSelfDeletingEvents initial eAddNew = do

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

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

236+ let event = mergeWith DMap.union

237+ [ mergeIncremental events

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

239+ ]

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

241+ eDelete = fforMaybe event $

242+ fmap (PatchDMap . DMap.fromDistinctAscList) .

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

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

245+ DMap.toList

246+ return $ ffor event $

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

248+ DMap.toList

src/Reflex/PostBuild/Class.hs+13−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 #-}

@@ -13,8 +14,9 @@ import Control.Monad.Exception

13import Control.Monad.Reader

14import Control.Monad.Reader

14import Control.Monad.Ref

15import Control.Monad.Ref

15import Control.Monad.Trans.Control

16import Control.Monad.Trans.Control

17+import qualified Data.Dependent.Map as DMap

18+import Data.Functor.Compose

16import Reflex.Class

19import Reflex.Class

17−import Reflex.Deletable.Class

18import Reflex.Host.Class

20import Reflex.Host.Class

19import Reflex.PerformEvent.Class

21import Reflex.PerformEvent.Class

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

34 {-# INLINABLE getPostBuild #-}

36 {-# INLINABLE getPostBuild #-}

35 getPostBuild = PostBuildT ask

37 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

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

42 {-# INLINABLE sample #-}

40 {-# INLINABLE sample #-}

43 sample = lift . sample

41 sample = lift . sample

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

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

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

91 getPostBuild = lift getPostBuild

89 getPostBuild = lift getPostBuild

90+

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

92+ sequenceDMapWithAdjust dm0 dm' = do

93+ postBuild <- getPostBuild

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

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

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

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

98+ 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

99+ return (result0, result')

src/Reflex/Spider/Internal.hs+4

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

2281instance MonadAtomicRef (SpiderHostFrame x) where

2282 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r

2283

2284+instance PrimMonad (SpiderHostFrame x) where

2285+ type PrimState (SpiderHostFrame x) = PrimState IO

2286+ primitive = SpiderHostFrame . EventM . primitive

2287+

2284--------------------------------------------------------------------------------

2288--------------------------------------------------------------------------------

2285-- Deprecated items

2289-- Deprecated items

2286--------------------------------------------------------------------------------

2290--------------------------------------------------------------------------------