develop...3c419d9 · reflex

git.iko.soy/reflex

17 files changed+1020−639

since splitsnapshots

unifiedsplit

default.nix−43 reflex.cabal+11−4 src/Data/TagMap.hs+39 src/Data/Unique/Tag/Local.hs+11 src/Data/Unique/Tag/Local/Internal.hs+59 src/Reflex/Dynamic.hs+1 src/Reflex/EventWriter/Base.hs+3 src/Reflex/FanTag.hs+23 src/Reflex/NotReady/Class.hs+5 src/Reflex/Patch/IntMap.hs+19−8 src/Reflex/PerformEvent/Base.hs+81−16 src/Reflex/Requester/Base.hs+14−529 src/Reflex/Requester/Base/Internal.hs+703 src/Reflex/Requester/Class.hs+1−1 src/Reflex/Spider/Internal.hs+4−1 test/EventWriterT.hs+15−11 test/RequesterT.hs+31−26

default.nixdeleted−43

@@ -1,43 +0,0 @@

1−{ mkDerivation, ghc, 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, random, ref-tf

5−, semigroupoids , semigroups, split, stdenv, stm, syb

6−, template-haskell , these, time, transformers

7−, transformers-compat, unbounded-delays, prim-uniq

8−, data-default, filepath, directory, filemanip, ghcjs-base

9−, monoidal-containers, witherable, profunctors

10−, semialign ? null, splitThese ? (semialign != null)

11−, useTemplateHaskell ? true

12−}:

13−mkDerivation {

14− pname = "reflex";

15− version = "0.6.2.4";

16− src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

17− libraryHaskellDepends = [

18− base bifunctors containers dependent-map dependent-sum

19− exception-transformers lens

20− MemoTrie monad-control mtl primitive ref-tf semigroupoids

21− semigroups stm syb template-haskell these transformers

22− transformers-compat prim-uniq

23− base bifunctors containers deepseq dependent-map dependent-sum

24− mtl ref-tf split transformers data-default

25− random time unbounded-delays monoidal-containers witherable

26− profunctors

27− ] ++ (if ghc.isGhcjs or false then [

28− ghcjs-base

29− ] else []) ++ (if !useTemplateHaskell then [] else [

30− haskell-src-exts haskell-src-meta

31− ]) ++ (if splitThese then [

32− semialign

33− ] else []);

34− testHaskellDepends = if ghc.isGhcjs or false then [] else [

35− hlint filepath directory filemanip

36− ];

37− configureFlags =

38− stdenv.lib.optional (!useTemplateHaskell) [ "-f-use-template-haskell" ] ++

39− stdenv.lib.optional (!splitThese) [ "-f-split-these" ];

40− homepage = "https://github.com/reflex-frp/reflex";

41− description = "Higher-order Functional Reactive Programming";

42− license = stdenv.lib.licenses.bsd3;

43−}

reflex.cabal+11−4

@@ -57,6 +57,7 @@ library

5757 containers >= 0.6 && < 0.7,

5858 data-default >= 0.5 && < 0.8,

5959 dependent-map >= 0.3 && < 0.4,

60+ dlist == 0.8.*,

6061 exception-transformers == 0.4.*,

6162 profunctors >= 5.3 && < 5.5,

6263 lens >= 4.7 && < 5,

@@ -91,12 +92,15 @@ library

9192 Data.FastWeakBag,

9293 Data.Functor.Misc,

9394 Data.Map.Misc,

95+ Data.TagMap,

96+ Data.Unique.Tag.Local,

97+ Data.Unique.Tag.Local.Internal,

9498 Data.WeakBag,

9599 Reflex,

96− Reflex.Class,

97100 Reflex.Adjustable.Class,

98101 Reflex.BehaviorWriter.Base,

99102 Reflex.BehaviorWriter.Class,

103+ Reflex.Class,

100104 Reflex.Collection,

101105 Reflex.Dynamic,

102106 Reflex.Dynamic.Uniq,

@@ -106,6 +110,7 @@ library

106110 Reflex.EventWriter,

107111 Reflex.EventWriter.Base,

108112 Reflex.EventWriter.Class,

113+ Reflex.FanTag,

109114 Reflex.FastWeak,

110115 Reflex.FunctorMaybe,

111116 Reflex.Host.Class,

@@ -127,6 +132,7 @@ library

127132 Reflex.Query.Base,

128133 Reflex.Query.Class,

129134 Reflex.Requester.Base,

135+ Reflex.Requester.Base.Internal,

130136 Reflex.Requester.Class,

131137 Reflex.Spider,

132138 Reflex.Spider.Internal,

@@ -259,14 +265,15 @@ test-suite RequesterT

259265 build-depends: base

260266 , containers

261267 , deepseq

262− , dependent-sum

263268 , dependent-map

269+ , dependent-sum

264270 , lens

265271 , mtl

272+ , primitive

273+ , ref-tf

274+ , reflex

266275 , these

267276 , transformers

268− , reflex

269− , ref-tf

270277

271278 if flag(split-these)

272279 build-depends: these-lens

src/Data/TagMap.hsnew file+39

@@ -0,0 +1,39 @@

1+{-# LANGUAGE PolyKinds #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+module Data.TagMap

4+ ( TagMap

5+ , unTagMap

6+ , fromDMap

7+ , toDMap

8+ , fromList

9+ , insert

10+ , size

11+ ) where

12+

13+import Data.IntMap (IntMap)

14+import qualified Data.IntMap as IntMap

15+import Data.Dependent.Map (DMap)

16+import qualified Data.Dependent.Map as DMap

17+import Data.Dependent.Sum (DSum (..))

18+import Data.Unique.Tag.Local

19+

20+import GHC.Exts (Any)

21+import Unsafe.Coerce

22+

23+-- | Like DMap, but with 'Data.Unique.Tag.Tag' as the keys. Implemented using 'Data.IntMap.IntMap' under the hood.

24+newtype TagMap x (v :: k -> *) = TagMap { unTagMap :: IntMap Any }

25+

26+fromDMap :: forall k x (v :: k -> *). DMap (Tag x) v -> TagMap x v

27+fromDMap = TagMap . IntMap.fromDistinctAscList . fmap (\((k :: Tag x (a :: k)) :=> v) -> (tagId k, (unsafeCoerce :: v a -> Any) v)) . DMap.toAscList

28+

29+toDMap :: forall x v. TagMap x v -> DMap (Tag x) v

30+toDMap = DMap.fromDistinctAscList . fmap (\(k, v) -> (unsafeTagFromId k :=> (unsafeCoerce :: Any -> v a) v)) . IntMap.toAscList . unTagMap

31+

32+insert :: forall x a v. Tag x a -> v a -> TagMap x v -> TagMap x v

33+insert k v = TagMap . IntMap.insert (tagId k) ((unsafeCoerce :: v a -> Any) v) . unTagMap

34+

35+fromList :: [DSum (Tag x) v] -> TagMap x v

36+fromList = TagMap . IntMap.fromList . fmap (\(t :=> v) -> (tagId t, (unsafeCoerce :: v a -> Any) v))

37+

38+size :: TagMap x v -> Int

39+size = IntMap.size . unTagMap

src/Data/Unique/Tag/Local.hsnew file+11

@@ -0,0 +1,11 @@

1+module Data.Unique.Tag.Local

2+ ( Tag

3+ , TagGen (..)

4+ , tagId

5+ , unsafeTagFromId

6+ , newTag

7+ , newTagGen

8+ , withTagGen

9+ ) where

10+

11+import Data.Unique.Tag.Local.Internal

src/Data/Unique/Tag/Local/Internal.hsnew file+59

@@ -0,0 +1,59 @@

1+-- | The type-safety of this module depends on two assumptions:

2+-- 1. If the `s` parameters on two `TagGen`s can unify, then they contain the same MutVar

3+-- 2. Two Tag values made from the same TagGen never contain the same Int

5+{-# LANGUAGE EmptyDataDecls #-}

6+{-# LANGUAGE DeriveFunctor #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE MagicHash #-}

13+module Data.Unique.Tag.Local.Internal where

14+

15+import Control.Monad.Exception

16+import Control.Monad.Primitive

17+import Control.Monad.Reader

18+import Data.Primitive.MutVar

19+import Data.GADT.Compare

20+import Data.Some

21+import GHC.Exts (Int (..), Int#, MutVar#, unsafeCoerce#)

22+

23+import Unsafe.Coerce

24+

25+newtype Tag x a = Tag Int

26+

27+tagId :: Tag x a -> Int

28+tagId (Tag n) = n

29+

30+-- | WARNING: If you construct a tag with the wrong type, it will result in

31+-- incorrect unsafeCoerce applications, which can segfault or cause arbitrary

32+-- other damage to your program

33+unsafeTagFromId :: Int -> Tag x a

34+unsafeTagFromId n = Tag n

35+

36+-- We use Int because it is supported by e.g. IntMap

37+newtype TagGen ps s = TagGen { unTagGen :: MutVar ps Int }

38+

39+instance Show (TagGen ps s) where

40+ show (TagGen (MutVar m)) = show $ I# ((unsafeCoerce# :: MutVar# ps Int -> Int#) m)

41+

42+instance GEq (TagGen ps) where

43+ TagGen a `geq` TagGen b =

44+ if a == b

45+ then Just $ unsafeCoerce Refl

46+ else Nothing

47+

48+newTag :: PrimMonad m => TagGen (PrimState m) s -> m (Tag s a)

49+newTag (TagGen r) = do

50+ n <- atomicModifyMutVar' r $ \x -> (succ x, x)

51+ pure $ Tag n

52+

53+newTagGen :: PrimMonad m => m (Some (TagGen (PrimState m)))

54+newTagGen = Some . TagGen <$> newMutVar minBound

55+

56+withTagGen :: PrimMonad m => (forall s. TagGen (PrimState m) s -> m a) -> m a

57+withTagGen f = do

58+ g <- newTagGen

59+ withSome g f

src/Reflex/Dynamic.hs+1

@@ -191,6 +191,7 @@ switchPromptlyDyn de =

191191 let eLag = switch $ current de

192192 eCoincidences = coincidence $ updated de

193193 in leftmost [eCoincidences, eLag]

194+--TODO: switchPromptlyDyn should get the `only` treatment like switchHoldPromptOnly

194195

195196-- | Split a 'Dynamic' pair into a pair of 'Dynamic's

196197splitDynPure :: Reflex t => Dynamic t (a, b) -> (Dynamic t a, Dynamic t b)

src/Reflex/EventWriter/Base.hs+3

@@ -200,6 +200,9 @@ sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidenceP

200200 h : t -> Just $ sconcat $ h :| t

201201 return (result0, result')

202202

203+switchHoldPromptOnlyIntMapIncremental :: (Reflex t, MonadHold t m) => IntMap (Event t a) -> Event t (PatchIntMap (Event t a)) -> m (Event t (IntMap a))

204+switchHoldPromptOnlyIntMapIncremental = switchHoldPromptOnlyIncremental mergeIntIncremental coincidencePatchIntMap

205+

203206-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

204207sequenceDMapWithAdjustEventWriterTWith

205208 :: forall t m p p' w k v v'

src/Reflex/FanTag.hsnew file+23

@@ -0,0 +1,23 @@

1+{-# LANGUAGE PolyKinds #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+module Reflex.FanTag

4+ ( EventSelectorTag

5+ , unEventSelectorTag

6+ , fanTag

7+ , selectTag

8+ ) where

10+import Data.Unique.Tag.Local

11+import Data.TagMap

12+import Reflex.Class

13+

14+import GHC.Exts (Any)

15+import Unsafe.Coerce

16+

17+newtype EventSelectorTag t x (v :: k -> *) = EventSelectorTag { unEventSelectorTag :: EventSelectorInt t Any }

18+

19+fanTag :: Reflex t => Event t (TagMap x v) -> EventSelectorTag t x v

20+fanTag = EventSelectorTag . fanInt . fmapCheap unTagMap

21+

22+selectTag :: forall t x v a. Reflex t => EventSelectorTag t x v -> Tag x a -> Event t (v a)

23+selectTag (EventSelectorTag s) = fmapCheap (unsafeCoerce :: Any -> v a) . selectInt s . tagId

src/Reflex/NotReady/Class.hs+5

@@ -25,6 +25,7 @@ import Reflex.PerformEvent.Base (PerformEventT (..))

2525import Reflex.PostBuild.Base (PostBuildT)

2626import Reflex.Query.Base (QueryT)

2727import Reflex.Requester.Base (RequesterT)

28+import Reflex.Requester.Base.Internal (RequesterInternalT)

2829import Reflex.TriggerEvent.Base (TriggerEventT)

2930

3031class Monad m => NotReady t m | m -> t where

@@ -72,6 +73,10 @@ instance NotReady t m => NotReady t (RequesterT t request response m) where

7273 notReadyUntil = lift . notReadyUntil

7374 notReady = lift notReady

7475

76+instance NotReady t m => NotReady t (RequesterInternalT s t request response m) where

77+ notReadyUntil = lift . notReadyUntil

78+ notReady = lift notReady

79+

7580instance NotReady t m => NotReady t (TriggerEventT t m) where

7681 notReadyUntil = lift . notReadyUntil

7782 notReady = lift notReady

src/Reflex/Patch/IntMap.hs+19−8

@@ -1,12 +1,16 @@

11{-# LANGUAGE DeriveFoldable #-}

22{-# LANGUAGE DeriveFunctor #-}

33{-# LANGUAGE DeriveTraversable #-}

4+{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE TemplateHaskell #-}

58{-# LANGUAGE TypeFamilies #-}

69-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for

710-- insert/update or delete of associations.

811module Reflex.Patch.IntMap where

912

13+import Control.Lens

1014import Data.IntMap.Strict (IntMap)

1115import qualified Data.IntMap.Strict as IntMap

1216import Data.Maybe

@@ -18,14 +22,6 @@ import Reflex.Patch.Class

1822-- and @Nothing@ means delete.

1923newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)

2024

21−-- | Apply the insertions or deletions to a given 'IntMap'.

22−instance Patch (PatchIntMap a) where

23− type PatchTarget (PatchIntMap a) = IntMap a

24− apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

25− let removes = IntMap.filter isNothing p

26− adds = IntMap.mapMaybe id p

27− in IntMap.union adds $ v `IntMap.difference` removes

28−

2925-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.

3026-- If the same key is modified by both patches, the one on the left will take

3127-- precedence.

@@ -34,11 +30,26 @@ instance Semigroup (PatchIntMap v) where

3430 -- PatchMap is idempotent, so stimes n is id for every n

3531 stimes = stimesIdempotentMonoid

3632

33+makeWrapped ''PatchIntMap

34+

35+-- | Apply the insertions or deletions to a given 'IntMap'.

36+instance Patch (PatchIntMap a) where

37+ type PatchTarget (PatchIntMap a) = IntMap a

38+ apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

39+ let removes = IntMap.filter isNothing p

40+ adds = IntMap.mapMaybe id p

41+ in IntMap.union adds $ v `IntMap.difference` removes

42+

3743-- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@

3844-- (that is, all inserts/updates), producing a @PatchIntMap b@.

3945mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b

4046mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m

4147

48+instance FunctorWithIndex Int PatchIntMap

49+instance FoldableWithIndex Int PatchIntMap

50+instance TraversableWithIndex Int PatchIntMap where

51+ itraversed = _Wrapped . itraversed . traversed

52+

4253-- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@

4354-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.

4455traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)

src/Reflex/PerformEvent/Base.hs+81−16

@@ -28,8 +28,10 @@ import Reflex.Class

2828import Reflex.Adjustable.Class

2929import Reflex.Host.Class

3030import Reflex.PerformEvent.Class

31−import Reflex.Requester.Base

31+import Reflex.Requester.Base.Internal

3232import Reflex.Requester.Class

33+import Reflex.EventWriter.Class

34+import Reflex.EventWriter.Base

3335

3436import Control.Lens

3537import Control.Monad.Exception

@@ -37,13 +39,21 @@ import Control.Monad.Identity

3739import Control.Monad.Primitive

3840import Control.Monad.Reader

3941import Control.Monad.Ref

40−import Data.Coerce

4142import Data.Dependent.Map (DMap)

4243import qualified Data.Dependent.Map as DMap

4344import Data.Dependent.Sum

45+import Data.Foldable

46+import Data.Functor.Compose

47+import Data.Functor.Misc

4448import Data.IntMap.Strict (IntMap)

4549import qualified Data.IntMap.Strict as IntMap

4650import qualified Data.Semigroup as S

51+import Data.Unique.Tag.Local

52+import Data.Sequence (Seq)

53+import Data.Tuple

54+import qualified Data.TagMap as TagMap

55+

56+import Debug.Trace

4757

4858-- | A function that fires events for the given 'EventTrigger's and then runs

4959-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'

@@ -68,7 +78,7 @@ instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m

6878 type PrimState (PerformEventT t m) = PrimState (HostFrame t)

6979 primitive = PerformEventT . lift . primitive

7080

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

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

7282 type Performable (PerformEventT t m) = HostFrame t

7383 {-# INLINABLE performEvent_ #-}

7484 performEvent_ = PerformEventT . requesting_

@@ -76,15 +86,60 @@ instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) wh

7686 performEvent = PerformEventT . requestingIdentity

7787

7888instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where

79− runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')

80− where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)

81− f a0 a' = do

82− result0 <- lift a0

83− result' <- requestingIdentity a'

84− return (result0, result')

85− traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

86− traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

87− traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

89+ runWithReplace a0 a' = PerformEventT $ RequesterT $ do

90+ env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask

91+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope s (HostFrame t))))

92+ runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env

93+ (result0, requests0) <- lift $ runA a0

94+ newA <- requestingIdentity $ traceEventWith (const "running new widget") $ runA <$> a'

95+ requests <- switchHoldPromptOnly requests0 $ traceEventWith (const "updating runWithReplace") $ fmapCheap snd newA

96+ --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

97+ RequesterInternalT $ tellEvent requests

98+ pure (result0, fmapCheap fst newA)

99+ traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do

100+ env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask

101+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope s (HostFrame t))))

102+ runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env

103+ children' <- requestingIdentity $ itraverse (\k -> runA . f k) <$> a'

104+ children0 <- lift $ itraverse (\k -> runA . f k) a0

105+ let results0 = fmap fst children0

106+ requests0 = fmap snd children0

107+ results' = fmap fst <$> children'

108+ requests' = fmap snd `fmapCheap` children'

109+ requests <- switchHoldPromptOnlyIncremental mergeIntIncremental coincidencePatchIntMap requests0 $ requests'

110+ --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

111+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m

112+ pure (results0, results')

113+ traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do

114+ env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask

115+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope s (HostFrame t))))) v' a)

116+ runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env

117+ where (PerformEventT (RequesterT a)) = f k v

118+ children' <- requestingIdentity $ traversePatchDMapWithKey runA <$> a'

119+ children0 <- lift $ DMap.traverseWithKey runA a0

120+ let results0 = DMap.map (snd . getCompose) children0

121+ requests0 = weakenDMapWith (fst . getCompose) children0

122+ results' = mapPatchDMap (snd . getCompose) <$> children'

123+ requests' = weakenPatchDMapWith (fst . getCompose) `fmapCheap` children'

124+ requests <- switchHoldPromptOnlyIncremental mergeMapIncremental coincidencePatchMap requests0 $ requests'

125+ --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

126+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m

127+ pure (results0, results')

128+ traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do

129+ env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask

130+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope s (HostFrame t))))) v' a)

131+ runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env

132+ where (PerformEventT (RequesterT a)) = f k v

133+ children' <- requestingIdentity $ traversePatchDMapWithMoveWithKey runA <$> a'

134+ children0 <- lift $ DMap.traverseWithKey runA a0

135+ let results0 = DMap.map (snd . getCompose) children0

136+ requests0 = weakenDMapWith (fst . getCompose) children0

137+ results' = mapPatchDMapWithMove (snd . getCompose) <$> children'

138+ requests' = weakenPatchDMapWithMoveWith (fst . getCompose) `fmapCheap` children'

139+ requests <- switchHoldPromptOnlyIncremental mergeMapIncrementalWithMove coincidencePatchMapWithMove requests0 $ requests'

140+ --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

141+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m

142+ pure (results0, results')

88143

89144defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)

90145 => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))

@@ -124,13 +179,14 @@ hostPerformEventT :: forall t m a.

124179 , MonadReflexHost t m

125180 , MonadRef m

126181 , Ref m ~ Ref IO

182+ , PrimMonad (HostFrame t)

127183 )

128184 => PerformEventT t m a

129185 -> m (a, FireCommand t m)

130186hostPerformEventT a = do

131187 (response, responseTrigger) <- newEventWithTriggerRef

132− (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response

133− eventToPerformHandle <- subscribeEvent eventToPerform

188+ (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) $ traceEventWith (const "response") response

189+ eventToPerformHandle <- subscribeEvent $ traceEventWith (const "eventToPerform") eventToPerform

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

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

136192 go ts = do

@@ -141,11 +197,20 @@ hostPerformEventT a = do

141197 case mToPerform of

142198 Nothing -> return [result']

143199 Just toPerform -> do

200+ traceM $ "toPerform: " <> case toPerform of

201+ RequestData _ reqs -> show (length reqs)

144202 responses <- runHostFrame $ traverseRequesterData (Identity <$>) toPerform

203+ let responseLength = case responses of

204+ ResponseData _ m -> TagMap.size m

205+ traceM $ "responses: " <> show responseLength

145206 mrt <- readRef responseTrigger

146207 let followupEventTriggers = case mrt of

147− Just rt -> [rt :=> Identity responses]

148− Nothing -> []

208+ Just rt -> do

209+ traceM "a"

210+ [rt :=> Identity responses]

211+ Nothing -> do

212+ traceM "b"

213+ []

149214 (result':) <$> go followupEventTriggers

150215 go triggers

151216

src/Reflex/Requester/Base.hs+14−529

@@ -1,537 +1,22 @@

11-- | This module provides 'RequesterT', the standard implementation of

22-- 'Requester'.

3−{-# LANGUAGE AllowAmbiguousTypes #-}

4−{-# LANGUAGE CPP #-}

5−{-# LANGUAGE EmptyDataDecls #-}

6−{-# LANGUAGE ExistentialQuantification #-}

7−{-# LANGUAGE FlexibleInstances #-}

8−{-# LANGUAGE GADTs #-}

9−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10−{-# LANGUAGE MultiParamTypeClasses #-}

11−{-# LANGUAGE Rank2Types #-}

12−{-# LANGUAGE RecursiveDo #-}

13−{-# LANGUAGE ScopedTypeVariables #-}

14−{-# LANGUAGE StandaloneDeriving #-}

15−{-# LANGUAGE TypeFamilies #-}

16−{-# LANGUAGE TypeOperators #-}

17−{-# LANGUAGE UndecidableInstances #-}

18−#ifdef USE_REFLEX_OPTIMIZER

19−{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

20−#endif

213module Reflex.Requester.Base

224 ( RequesterT (..)

5+ , RequestData (..)

6+ , ResponseData (..)

7+ , RequestEnvelope (..)

238 , runRequesterT

24− , withRequesterT

25− , runWithReplaceRequesterTWith

26− , traverseIntMapWithKeyWithAdjustRequesterTWith

27− , traverseDMapWithKeyWithAdjustRequesterTWith

28− , RequesterData

29− , RequesterDataKey

9+-- , withRequesterT

10+-- , RequesterData

11+-- , RequesterDataKey

3012 , traverseRequesterData

31− , forRequesterData

32− , requesterDataToList

33− , singletonRequesterData

34− , matchResponsesWithRequests

35− , multiEntry

36− , unMultiEntry

37− , requesting'

13+-- , forRequesterData

14+-- , requesterDataToList

15+-- , singletonRequesterData

16+-- , matchResponsesWithRequests

17+-- , multiEntry

18+-- , unMultiEntry

19+-- , requesting'

3820 ) where

3921

40−import Reflex.Class

41−import Reflex.Adjustable.Class

42−import Reflex.Dynamic

43−import Reflex.Host.Class

44−import Reflex.PerformEvent.Class

45−import Reflex.PostBuild.Class

46−import Reflex.Requester.Class

47−import Reflex.TriggerEvent.Class

48−

49−import Control.Applicative (liftA2)

50−import Control.Monad.Exception

51−import Control.Monad.Identity

52−import Control.Monad.Primitive

53−import Control.Monad.Reader

54−import Control.Monad.Ref

55−import Control.Monad.State.Strict

56−import Data.Bits

57−import Data.Coerce

58−import Data.Dependent.Map (DMap, DSum (..))

59−import qualified Data.Dependent.Map as DMap

60−import Data.Functor.Compose

61−import Data.Functor.Misc

62−import Data.IntMap.Strict (IntMap)

63−import qualified Data.IntMap.Strict as IntMap

64−import Data.Map (Map)

65−import qualified Data.Map as Map

66−import Data.Monoid ((<>))

67−import Data.Proxy

68−import qualified Data.Semigroup as S

69−import Data.Some (Some(Some))

70−import Data.Type.Equality

71−import Data.Unique.Tag

72−

73−import GHC.Exts (Any)

74−import Unsafe.Coerce

75−

76−--TODO: Make this module type-safe

77−

78−newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

79−

80−newtype RequesterData f = RequesterData (TagMap (Entry f))

81−

82−data RequesterDataKey a where

83− RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

84− RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead

85− RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

86− RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

87−

88−singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

89−singletonRequesterData rdk v = case rdk of

90− RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

91− RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

92− RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

93− RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

94−

95−requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

96−requesterDataToList (RequesterData m) = do

97− k :=> Entry e <- tagMapToList m

98− case myKeyType k of

99− MyTagType_Single -> return $ RequesterDataKey_Single k :=> e

100− MyTagType_Multi -> do

101− (k', e') <- IntMap.toList e

102− k'' :=> e'' <- requesterDataToList e'

103− return $ RequesterDataKey_Multi k k' k'' :=> e''

104− MyTagType_Multi2 -> do

105− (k', e') <- Map.toList e

106− (k'', e'') <- IntMap.toList e'

107− k''' :=> e''' <- requesterDataToList e''

108− return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

109− MyTagType_Multi3 -> do

110− (k', e') <- IntMap.toList e

111− (k'', e'') <- IntMap.toList e'

112− k''' :=> e''' <- requesterDataToList e''

113− return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''

114−

115−singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

116−singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

117−

118−tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

119−tagMapToList (TagMap m) = f <$> IntMap.toList m

120− where f :: (Int, Any) -> DSum MyTag f

121− f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v

122−

123−traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

124−traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

125− where

126− g :: Int -> Any -> t Any

127− g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)

128−

129−-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse

130−traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)

131−traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order

132− where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

133− go k (Entry request) = Entry <$> case myKeyType k of

134− MyTagType_Single -> f request

135− MyTagType_Multi -> traverse (traverseRequesterData f) request

136− MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

137− MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

138−

139−-- | 'traverseRequesterData' with its arguments flipped

140−forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)

141−forRequesterData r f = traverseRequesterData f r

142−

143−data MyTagType :: * -> * where

144− MyTagType_Single :: MyTagType (Single a)

145− MyTagType_Multi :: MyTagType Multi

146− MyTagType_Multi2 :: MyTagType (Multi2 k)

147− MyTagType_Multi3 :: MyTagType Multi3

148−

149−myKeyType :: MyTag x -> MyTagType x

150−myKeyType (MyTag k) = case k .&. 0x3 of

151− 0x0 -> unsafeCoerce MyTagType_Single

152− 0x1 -> unsafeCoerce MyTagType_Multi

153− 0x2 -> unsafeCoerce MyTagType_Multi2

154− 0x3 -> unsafeCoerce MyTagType_Multi3

155− t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t

156−

157−data Single a

158−data Multi

159−data Multi2 (k :: * -> *)

160−data Multi3

161−

162−class MyTagTypeOffset x where

163− myTagTypeOffset :: proxy x -> Int

164−

165−instance MyTagTypeOffset (Single a) where

166− myTagTypeOffset _ = 0x0

167−

168−instance MyTagTypeOffset Multi where

169− myTagTypeOffset _ = 0x1

170−

171−instance MyTagTypeOffset (Multi2 k) where

172− myTagTypeOffset _ = 0x2

173−

174−instance MyTagTypeOffset Multi3 where

175− myTagTypeOffset _ = 0x3

176−

177−type family EntryContents request a where

178− EntryContents request (Single a) = request a

179− EntryContents request Multi = IntMap (RequesterData request)

180− EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))

181− EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

182−

183−newtype Entry request x = Entry { unEntry :: EntryContents request x }

184−

185−{-# INLINE singleEntry #-}

186−singleEntry :: f a -> Entry f (Single a)

187−singleEntry = Entry

188−

189−{-# INLINE multiEntry #-}

190−multiEntry :: IntMap (RequesterData f) -> Entry f Multi

191−multiEntry = Entry

192−

193−{-# INLINE unMultiEntry #-}

194−unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)

195−unMultiEntry = unEntry

196−

197−-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes

198−-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another

199−newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

200−

201−newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)

202−

203−{-# INLINE castMyTagWrap #-}

204−castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)

205−castMyTagWrap = coerce

206−

207−instance GEq MyTag where

208− (MyTag a) `geq` (MyTag b) =

209− if a == b

210− then Just $ unsafeCoerce Refl

211− else Nothing

212−

213−instance GCompare MyTag where

214− (MyTag a) `gcompare` (MyTag b) =

215− case a `compare` b of

216− LT -> GLT

217− EQ -> unsafeCoerce GEQ

218− GT -> GGT

219−

220−instance GEq (MyTagWrap f) where

221− (MyTagWrap a) `geq` (MyTagWrap b) =

222− if a == b

223− then Just $ unsafeCoerce Refl

224− else Nothing

225−

226−instance GCompare (MyTagWrap f) where

227− (MyTagWrap a) `gcompare` (MyTagWrap b) =

228− case a `compare` b of

229− LT -> GLT

230− EQ -> unsafeCoerce GEQ

231− GT -> GGT

232−

233−data RequesterState t (request :: * -> *) = RequesterState

234− { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom

235− , _requesterState_requests :: ![(Int, Event t Any)]

236− }

237−

238−-- | A basic implementation of 'Requester'.

239−newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }

240− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

241−-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2

242−#if MIN_VERSION_base(4,9,1)

243− , MonadAsyncException

244−#endif

245− )

246−

247−deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)

248−deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)

249−deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)

250−deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

251−

252−instance PrimMonad m => PrimMonad (RequesterT t request response m) where

253− type PrimState (RequesterT t request response m) = PrimState m

254− primitive = lift . primitive

255−

256−-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

257−instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where

258− mempty = pure mempty

259− mappend = liftA2 mappend

260−

261−instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where

262− (<>) = liftA2 (S.<>)

263−

264−

265−-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever

266−-- requests are made, and responses should be provided in the input 'Event'.

267−-- The 'Tag' keys will be used to return the responses to the same place the

268−-- requests were issued.

269−runRequesterT :: (Reflex t, Monad m)

270− => RequesterT t request response m a

271− -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse

272− -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild

273−runRequesterT (RequesterT a) responses = do

274− (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $

275− coerceEvent responses

276− return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

277−

278−-- | Map a function over the request and response of a 'RequesterT'

279−withRequesterT

280− :: (Reflex t, MonadFix m)

281− => (forall x. req x -> req' x) -- ^ The function to map over the request

282− -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response

283− -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed

284− -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'

285−withRequesterT freq frsp child = do

286− rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'

287− (a, req) <- lift $ runRequesterT child rsp

288− rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $

289− fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req

290− return a

291−

292−instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

293− type Request (RequesterT t request response m) = request

294− type Response (RequesterT t request response m) = response

295− requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))

296− requesting_ = void . tagRequest . fmapCheap singleEntry

297−

298−{-# INLINE tagRequest #-}

299−tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))

300−tagRequest req = do

301− old <- RequesterT get

302− let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)

303− t = MyTagWrap n

304− RequesterT $ put $ RequesterState

305− { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

306− , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old

307− }

308− return t

309−

310−{-# INLINE responseFromTag #-}

311−responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

312−responseFromTag (MyTagWrap t) = do

313− responses :: EventSelectorInt t Any <- RequesterT ask

314− return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

315−

316−instance MonadTrans (RequesterT t request response) where

317− lift = RequesterT . lift . lift

318−

319−instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where

320− type Performable (RequesterT t request response m) = Performable m

321− performEvent_ = lift . performEvent_

322− performEvent = lift . performEvent

323−

324−instance MonadRef m => MonadRef (RequesterT t request response m) where

325− type Ref (RequesterT t request response m) = Ref m

326− newRef = lift . newRef

327− readRef = lift . readRef

328− writeRef r = lift . writeRef r

329−

330−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where

331− newEventWithTrigger = lift . newEventWithTrigger

332− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

333−

334−instance MonadReader r m => MonadReader r (RequesterT t request response m) where

335− ask = lift ask

336− local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a

337− reader = lift . reader

338−

339−instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where

340− runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

341− traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental

342− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

343− traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

344− traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

345−

346−requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

347−requesting' = responseFromTag . castMyTagWrap <=< tagRequest

348−

349−{-# INLINABLE runWithReplaceRequesterTWith #-}

350−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

351− , MonadFix m

352− )

353− => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

354− -> RequesterT t request response m a

355− -> Event t (RequesterT t request response m b)

356− -> RequesterT t request response m (a, Event t b)

357−runWithReplaceRequesterTWith f a0 a' = do

358− rec na' <- numberOccurrencesFrom 1 a'

359− responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

360− let responses' = fanInt responses

361− ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'

362− requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'

363− return (result0, fmapCheap (fst . snd) v')

364−

365−{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

366−traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

367− ( Reflex t

368− , MonadHold t m

369− , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))

370− , Patch (p (Event t (IntMap (RequesterData request))))

371− , Functor p

372− , MonadFix m

373− )

374− => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))

375− -> IntMap (IntMap.Key, v)

376− -> Event t (p (IntMap.Key, v))

377− -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))

378− )

379− -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))

380− -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))

381− -> (IntMap.Key -> v -> RequesterT t request response m v')

382− -> IntMap v

383− -> Event t (p v)

384− -> RequesterT t request response m (IntMap v', Event t (p v'))

385−traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

386− rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

387− let responses :: EventSelectorInt t (IntMap (RequesterData response))

388− responses = fanInt $ fmapCheap unpack response

389− unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))

390− unpack = unEntry

391− pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3

392− pack = Entry

393− f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

394− f' k (n, v) = do

395− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?

396− return (fmapCheap (IntMap.singleton n) myRequests, result)

397− ndm' <- numberOccurrencesFrom 1 dm'

398− (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable

399− let result0 = fmap snd children0

400− result' = fforCheap children' $ fmap snd

401− requests0 :: IntMap (Event t (IntMap (RequesterData request)))

402− requests0 = fmap fst children0

403− requests' :: Event t (p (Event t (IntMap (RequesterData request))))

404− requests' = fforCheap children' $ fmap fst

405− promptRequests :: Event t (IntMap (IntMap (RequesterData request)))

406− promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

407− requests <- holdIncremental requests0 requests'

408− return (result0, result')

409−

410−{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

411−traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

412− ( GCompare k

413− , Reflex t

414− , MonadHold t m

415− , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))

416− , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))

417− , MonadFix m

418− )

419− => (forall k' v1 v2. GCompare k'

420− => (forall a. k' a -> v1 a -> m (v2 a))

421− -> DMap k' v1

422− -> Event t (p k' v1)

423− -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

424− )

425− -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)

426− -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

427− -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)

428− -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

429− -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

430− -> DMap k v

431− -> Event t (p k v)

432− -> RequesterT t request response m (DMap k v', Event t (p k v'))

433−traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

434− rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

435− let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

436− responses = fanMap $ fmapCheap unpack response

437− unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

438− unpack = unEntry

439− pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

440− pack = Entry

441− f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

442− f' k (Compose (n, v)) = do

443− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))

444− return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

445− ndm' <- numberOccurrencesFrom 1 dm'

446− (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

447− let result0 = DMap.map (snd . getCompose) children0

448− result' = fforCheap children' $ mapPatch $ snd . getCompose

449− requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))

450− requests0 = weakenDMapWith (fst . getCompose) children0

451− requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))

452− requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

453− promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))

454− promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

455− requests <- holdIncremental requests0 requests'

456− return (result0, result')

457−

458−data Decoder rawResponse response =

459− forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

460−

461−-- | Matches incoming responses with previously-sent requests

462−-- and uses the provided request "decoder" function to process

463−-- incoming responses.

464−matchResponsesWithRequests

465− :: forall t rawRequest rawResponse request response m.

466− ( MonadFix m

467− , MonadHold t m

468− , Reflex t

469− )

470− => (forall a. request a -> (rawRequest, rawResponse -> response a))

471− -- ^ Given a request (from 'Requester'), produces the wire format of the

472− -- request and a function used to process the associated response

473− -> Event t (RequesterData request)

474− -- ^ The outgoing requests

475− -> Event t (Int, rawResponse)

476− -- ^ The incoming responses, tagged by an identifying key

477− -> m ( Event t (Map Int rawRequest)

478− , Event t (RequesterData response)

479− )

480− -- ^ A map of outgoing wire-format requests and an event of responses keyed

481− -- by the 'RequesterData' key of the associated outgoing request

482−matchResponsesWithRequests f send recv = do

483− rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

484− waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

485− holdIncremental mempty $ leftmost

486− [ fmap (\(_, outstanding, _) -> outstanding) outgoing

487− , snd <$> incoming

488− ]

489− let outgoing = processOutgoing nextId send

490− incoming = processIncoming waitingFor recv

491− return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)

492− where

493− -- Tags each outgoing request with an identifying integer key

494− -- and returns the next available key, a map of response decoders

495− -- for requests for which there are outstanding responses, and the

496− -- raw requests to be sent out.

497− processOutgoing

498− :: Behavior t Int

499− -- The next available key

500− -> Event t (RequesterData request)

501− -- The outgoing request

502− -> Event t ( Int

503− , PatchMap Int (Decoder rawResponse response)

504− , Map Int rawRequest )

505− -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests

506− processOutgoing nextId out = flip pushAlways out $ \dm -> do

507− oldNextId <- sample nextId

508− let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do

509− n <- get

510− put $ succ n

511− let (rawReq, rspF) = f v

512− return (n, rawReq, Decoder k rspF)

513− patchWaitingFor = PatchMap $ Map.fromList $

514− (\(n, _, dec) -> (n, Just dec)) <$> result

515− toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result

516− return (newNextId, patchWaitingFor, toSend)

517− -- Looks up the each incoming raw response in a map of response

518− -- decoders and returns the decoded response and a patch that can

519− -- be used to clear the ID of the consumed response out of the queue

520− -- of expected responses.

521− processIncoming

522− :: Incremental t (PatchMap Int (Decoder rawResponse response))

523− -- A map of outstanding expected responses

524− -> Event t (Int, rawResponse)

525− -- A incoming response paired with its identifying key

526− -> Event t (RequesterData response, PatchMap Int v)

527− -- The decoded response and a patch that clears the outstanding responses queue

528− processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do

529− wf <- sample $ currentIncremental waitingFor

530− case Map.lookup n wf of

531− Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..

532− Just (Decoder k rspF) -> do

533− let rsp = rspF rawRsp

534− return $ Just

535− ( singletonRequesterData k rsp

536− , PatchMap $ Map.singleton n Nothing

537− )

22+import Reflex.Requester.Base.Internal

src/Reflex/Requester/Base/Internal.hsnew file+703

@@ -0,0 +1,703 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE EmptyDataDecls #-}

4+{-# LANGUAGE ExistentialQuantification #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE Rank2Types #-}

10+{-# LANGUAGE RecursiveDo #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE StandaloneDeriving #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE UndecidableInstances #-}

16+{-# LANGUAGE InstanceSigs #-}

17+#ifdef USE_REFLEX_OPTIMIZER

18+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

19+#endif

20+module Reflex.Requester.Base.Internal where

21+

22+import Reflex.Class

23+import Reflex.Adjustable.Class

24+import Reflex.Dynamic

25+import Reflex.Host.Class

26+import Reflex.PerformEvent.Class

27+import Reflex.PostBuild.Class

28+import Reflex.Requester.Class

29+import Reflex.TriggerEvent.Class

30+import Reflex.EventWriter.Base

31+import Reflex.EventWriter.Class

32+

33+import Control.Applicative (liftA2)

34+import Control.Monad.Exception

35+import Control.Monad.Identity

36+import Control.Monad.Primitive

37+import Control.Monad.Reader

38+import Control.Monad.Ref

39+import Control.Monad.State.Strict

40+import Data.Bits

41+import Data.Coerce

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

43+import qualified Data.Dependent.Map as DMap

44+import Data.Functor.Compose

45+import Data.Functor.Misc

46+import Data.IntMap.Strict (IntMap)

47+import qualified Data.IntMap.Strict as IntMap

48+import Data.Map (Map)

49+import qualified Data.Map as Map

50+import Data.Monoid ((<>))

51+import Data.Proxy

52+import qualified Data.Semigroup as S

53+import Data.Some (Some(Some))

54+import Data.Type.Equality

55+import Data.Sequence (Seq)

56+import qualified Data.Sequence as Seq

57+import Data.TagMap (TagMap)

58+import qualified Data.TagMap as TagMap

59+import Reflex.FanTag

60+import Data.Unique.Tag.Local

61+import qualified Data.Unique.Tag as Global

62+import Data.GADT.Compare

63+import Data.Witherable

64+import Data.Foldable

65+

66+import Debug.Trace

67+

68+--TODO: The use of Seq in this module could probably be replaced with something

69+--even cheaper. We do need O(1) append, but we don't need associativity until

70+--the very end, when we're smashing everything together. This could be

71+--implemented as a binary tree whose representation isn't associative, but which

72+--doesn't allow any external party to observe the lack of associativity.

73+

74+data RequestData ps request = forall s. RequestData !(TagGen ps s) !(Seq (RequestEnvelope s request))

75+data ResponseData ps response = forall s. ResponseData !(TagGen ps s) !(TagMap s response)

76+

77+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequestData (PrimState m) request -> m (ResponseData (PrimState m) response)

78+traverseRequesterData f (RequestData tg es) = ResponseData tg . TagMap.fromList <$> wither g (toList es)

79+ where g (RequestEnvelope mt req) = case mt of

80+ Just t -> Just . (t :=>) <$> f req

81+ Nothing -> Nothing <$ f req

82+

83+runRequesterT :: forall t request response m a

84+ . ( Reflex t

85+ , PrimMonad m

86+ , MonadFix m

87+ )

88+ => RequesterT t request response m a

89+ -> Event t (ResponseData (PrimState m) response)

90+ -> m (a, Event t (RequestData (PrimState m) request))

91+runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (Seq (RequestEnvelope s request))) -> do

92+ (_, tg) <- RequesterInternalT ask

93+ result <- a

94+ let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of

95+ Nothing -> trace ("runRequesterT: bad TagGen: expected " <> show tg <> " but got " <> show tg') Nothing --TODO: Warn somehow

96+ Just Refl -> trace "runRequesterT: good TagGen" $ Just m

97+ pure (responses, (result, fmapCheap (RequestData tg) requests))

98+

99+instance MonadTrans (RequesterInternalT s t request response) where

100+ lift = RequesterInternalT . lift . lift

101+

102+instance MonadTrans (RequesterT t request response) where

103+ lift a = RequesterT $ RequesterInternalT $ lift $ lift a

104+

105+-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever

106+-- requests are made, and responses should be provided in the input 'Event'.

107+-- The 'Tag' keys will be used to return the responses to the same place the

108+-- requests were issued.

109+withRequesterInternalT

110+ :: ( Reflex t

111+ , PrimMonad m

112+ , MonadFix m

113+ )

114+ => (forall s. Event t (Seq (RequestEnvelope s request)) -> RequesterInternalT s t request response m (Event t (TagMap s response), a))

115+ -> m a

116+withRequesterInternalT f = withTagGen $ \tg -> do

117+ rec let RequesterInternalT a = f requests

118+ ((responses, result), requests) <- runEventWriterT $ runReaderT a (fanTag responses, tg)

119+ pure result

120+

121+data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)

122+

123+newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: forall s. RequesterInternalT s t request response m a }

124+

125+instance Functor m => Functor (RequesterT t request response m) where

126+ fmap f (RequesterT x) = RequesterT $ fmap f x

127+

128+instance Monad m => Applicative (RequesterT t request response m) where

129+ pure x = RequesterT $ pure x

130+ RequesterT f <*> RequesterT x = RequesterT $ f <*> x

131+ liftA2 f (RequesterT a) (RequesterT b) = RequesterT $ liftA2 f a b

132+ RequesterT f <* RequesterT x = RequesterT $ f <* x

133+ RequesterT f *> RequesterT x = RequesterT $ f *> x

134+

135+instance Monad m => Monad (RequesterT t request response m) where

136+ return = pure

137+ RequesterT mx >>= f = RequesterT $ mx >>= \x -> case f x of

138+ RequesterT y -> y

139+

140+instance MonadFix m => MonadFix (RequesterT t request response m) where

141+ mfix f = RequesterT $ mfix $ \x -> case f x of

142+ RequesterT a -> a

143+

144+instance MonadIO m => MonadIO (RequesterT t request respnose m) where

145+ liftIO a = RequesterT $ liftIO a

146+

147+instance MonadException m => MonadException (RequesterT t request respnose m) where

148+ throw e = RequesterT $ throw e

149+

150+newtype RequesterInternalT s t request response m a = RequesterInternalT { unRequesterInternalT :: ReaderT (EventSelectorTag t s response, TagGen (PrimState m) s) (EventWriterT t (Seq (RequestEnvelope s request)) m) a }

151+ deriving

152+ ( Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

153+#if MIN_VERSION_base(4,9,1)

154+ , MonadAsyncException

155+#endif

156+ )

157+

158+-- I don't think this can actually be supported without an unsafeCoerce

159+-- #if MIN_VERSION_base(4,9,1)

160+-- instance MonadAsyncException m => MonadAsyncException (RequesterT t request response m) where

161+-- mask f = RequesterT $ mask $ \unmask -> unRequesterT $ f $ \x -> RequesterT $ unmask $ unRequesterT x

162+-- #endif

163+

164+instance MonadSample t m => MonadSample t (RequesterT t request response m)

165+instance MonadHold t m => MonadHold t (RequesterT t request response m)

166+instance PostBuild t m => PostBuild t (RequesterT t request response m)

167+instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

168+

169+instance MonadSample t m => MonadSample t (RequesterInternalT s t request response m)

170+instance MonadHold t m => MonadHold t (RequesterInternalT s t request response m)

171+instance PostBuild t m => PostBuild t (RequesterInternalT s t request response m)

172+instance TriggerEvent t m => TriggerEvent t (RequesterInternalT s t request response m)

173+

174+instance PrimMonad m => PrimMonad (RequesterT t request response m) where

175+ type PrimState (RequesterT t request response m) = PrimState m

176+ primitive = lift . primitive

177+

178+-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

179+instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where

180+ mempty = pure mempty

181+ mappend = liftA2 mappend

182+

183+instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where

184+ (<>) = liftA2 (S.<>)

185+

186+instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where

187+ type Performable (RequesterT t request response m) = Performable m

188+ performEvent_ = lift . performEvent_

189+ performEvent = lift . performEvent

190+

191+instance MonadRef m => MonadRef (RequesterT t request response m) where

192+ type Ref (RequesterT t request response m) = Ref m

193+ newRef = lift . newRef

194+ readRef = lift . readRef

195+ writeRef r = lift . writeRef r

196+

197+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where

198+ newEventWithTrigger = lift . newEventWithTrigger

199+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

200+

201+instance MonadReader r m => MonadReader r (RequesterT t request response m) where

202+ ask = lift ask

203+ local f (RequesterT a) = RequesterT $ RequesterInternalT $ mapReaderT (mapEventWriterT $ local f) $ unRequesterInternalT a

204+ reader = lift . reader

205+

206+instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where

207+ type Request (RequesterT t request response m) = request

208+ type Response (RequesterT t request response m) = response

209+ requesting e = RequesterT $ requesting e

210+ requesting_ e = RequesterT $ requesting_ e

211+

212+instance (Reflex t, PrimMonad m) => Requester t (RequesterInternalT s t request response m) where

213+ type Request (RequesterInternalT s t request response m) = request

214+ type Response (RequesterInternalT s t request response m) = response

215+ requesting e = RequesterInternalT $ do

216+ (s, tg) <- ask

217+ t <- lift $ lift $ newTag tg

218+ tellEvent $ fmapCheap (Seq.singleton . RequestEnvelope (Just t)) e

219+ pure $ selectTag s t

220+ requesting_ e = RequesterInternalT $ do

221+ tellEvent $ fmapCheap (Seq.singleton . RequestEnvelope Nothing) e

222+

223+instance (Adjustable t m, MonadHold t m) => Adjustable t (RequesterInternalT s t request response m) where

224+ {-# INLINABLE runWithReplace #-}

225+ runWithReplace (RequesterInternalT a0) a' = RequesterInternalT $ runWithReplace a0 (coerceEvent a')

226+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

227+ traverseIntMapWithKeyWithAdjust f dm0 dm' = RequesterInternalT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'

228+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

229+ traverseDMapWithKeyWithAdjust f dm0 dm' = RequesterInternalT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

230+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

231+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = RequesterInternalT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'

232+

233+instance (Adjustable t m, MonadHold t m) => Adjustable t (RequesterT t request response m) where

234+ {-# INLINABLE runWithReplace #-}

235+ runWithReplace (RequesterT a0) a' = RequesterT $ runWithReplace a0 (fmapCheap unRequesterT a')

236+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

237+ traverseIntMapWithKeyWithAdjust f dm0 dm' = RequesterT $ traverseIntMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) dm0 dm'

238+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

239+ traverseDMapWithKeyWithAdjust f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) dm0 dm'

240+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

241+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) dm0 dm'

242+

243+{-# INLINABLE runWithReplaceRequesterTWith #-}

244+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

245+ , MonadFix m

246+ )

247+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

248+ -> RequesterT t request response m a

249+ -> Event t (RequesterT t request response m b)

250+ -> RequesterT t request response m (a, Event t b)

251+runWithReplaceRequesterTWith f (RequesterT a0) a' = RequesterT $ do

252+ pure undefined

253+

254+{-

255+import GHC.Exts (Any)

256+import Unsafe.Coerce

257+

258+--TODO: Make this module type-safe

259+

260+newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

261+

262+newtype RequesterData f = RequesterData (TagMap (Entry f))

263+

264+data RequesterDataKey a where

265+ RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

266+ RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead

267+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

268+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

269+

270+singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

271+singletonRequesterData rdk v = case rdk of

272+ RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

273+ RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

274+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

275+ RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

276+

277+requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

278+requesterDataToList (RequesterData m) = do

279+ k :=> Entry e <- tagMapToList m

280+ case myKeyType k of

281+ MyTagType_Single -> return $ RequesterDataKey_Single k :=> e

282+ MyTagType_Multi -> do

283+ (k', e') <- IntMap.toList e

284+ k'' :=> e'' <- requesterDataToList e'

285+ return $ RequesterDataKey_Multi k k' k'' :=> e''

286+ MyTagType_Multi2 -> do

287+ (k', e') <- Map.toList e

288+ (k'', e'') <- IntMap.toList e'

289+ k''' :=> e''' <- requesterDataToList e''

290+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

291+ MyTagType_Multi3 -> do

292+ (k', e') <- IntMap.toList e

293+ (k'', e'') <- IntMap.toList e'

294+ k''' :=> e''' <- requesterDataToList e''

295+ return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''

296+

297+singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

298+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

299+

300+tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

301+tagMapToList (TagMap m) = f <$> IntMap.toList m

302+ where f :: (Int, Any) -> DSum MyTag f

303+ f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v

304+

305+traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

306+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

307+ where

308+ g :: Int -> Any -> t Any

309+ g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)

310+

311+-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse

312+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)

313+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order

314+ where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

315+ go k (Entry request) = Entry <$> case myKeyType k of

316+ MyTagType_Single -> f request

317+ MyTagType_Multi -> traverse (traverseRequesterData f) request

318+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

319+ MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

320+

321+-- | 'traverseRequesterData' with its arguments flipped

322+forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)

323+forRequesterData r f = traverseRequesterData f r

324+

325+data MyTagType :: * -> * where

326+ MyTagType_Single :: MyTagType (Single a)

327+ MyTagType_Multi :: MyTagType Multi

328+ MyTagType_Multi2 :: MyTagType (Multi2 k)

329+ MyTagType_Multi3 :: MyTagType Multi3

330+

331+myKeyType :: MyTag x -> MyTagType x

332+myKeyType (MyTag k) = case k .&. 0x3 of

333+ 0x0 -> unsafeCoerce MyTagType_Single

334+ 0x1 -> unsafeCoerce MyTagType_Multi

335+ 0x2 -> unsafeCoerce MyTagType_Multi2

336+ 0x3 -> unsafeCoerce MyTagType_Multi3

337+ t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t

338+

339+data Single a

340+data Multi

341+data Multi2 (k :: * -> *)

342+data Multi3

343+

344+class MyTagTypeOffset x where

345+ myTagTypeOffset :: proxy x -> Int

346+

347+instance MyTagTypeOffset (Single a) where

348+ myTagTypeOffset _ = 0x0

349+

350+instance MyTagTypeOffset Multi where

351+ myTagTypeOffset _ = 0x1

352+

353+instance MyTagTypeOffset (Multi2 k) where

354+ myTagTypeOffset _ = 0x2

355+

356+instance MyTagTypeOffset Multi3 where

357+ myTagTypeOffset _ = 0x3

358+

359+type family EntryContents request a where

360+ EntryContents request (Single a) = request a

361+ EntryContents request Multi = IntMap (RequesterData request)

362+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))

363+ EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

364+

365+newtype Entry request x = Entry { unEntry :: EntryContents request x }

366+

367+{-# INLINE singleEntry #-}

368+singleEntry :: f a -> Entry f (Single a)

369+singleEntry = Entry

370+

371+{-# INLINE multiEntry #-}

372+multiEntry :: IntMap (RequesterData f) -> Entry f Multi

373+multiEntry = Entry

374+

375+{-# INLINE unMultiEntry #-}

376+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)

377+unMultiEntry = unEntry

378+

379+-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes

380+-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another

381+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

382+

383+newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)

384+

385+{-# INLINE castMyTagWrap #-}

386+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)

387+castMyTagWrap = coerce

388+

389+instance GEq MyTag where

390+ (MyTag a) `geq` (MyTag b) =

391+ if a == b

392+ then Just $ unsafeCoerce Refl

393+ else Nothing

394+

395+instance GCompare MyTag where

396+ (MyTag a) `gcompare` (MyTag b) =

397+ case a `compare` b of

398+ LT -> GLT

399+ EQ -> unsafeCoerce GEQ

400+ GT -> GGT

401+

402+instance GEq (MyTagWrap f) where

403+ (MyTagWrap a) `geq` (MyTagWrap b) =

404+ if a == b

405+ then Just $ unsafeCoerce Refl

406+ else Nothing

407+

408+instance GCompare (MyTagWrap f) where

409+ (MyTagWrap a) `gcompare` (MyTagWrap b) =

410+ case a `compare` b of

411+ LT -> GLT

412+ EQ -> unsafeCoerce GEQ

413+ GT -> GGT

414+

415+data RequesterState t (request :: * -> *) = RequesterState

416+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom

417+ , _requesterState_requests :: ![(Int, Event t Any)]

418+ }

419+

420+-- | A basic implementation of 'Requester'.

421+newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }

422+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

423+-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2

424+#if MIN_VERSION_base(4,9,1)

425+ , MonadAsyncException

426+#endif

427+ )

428+

429+

430+-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever

431+-- requests are made, and responses should be provided in the input 'Event'.

432+-- The 'Tag' keys will be used to return the responses to the same place the

433+-- requests were issued.

434+runRequesterT :: (Reflex t, Monad m)

435+ => RequesterT t request response m a

436+ -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse

437+ -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild

438+runRequesterT (RequesterT a) responses = do

439+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $

440+ coerceEvent responses

441+ return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

442+

443+-- | Map a function over the request and response of a 'RequesterT'

444+withRequesterT

445+ :: (Reflex t, MonadFix m)

446+ => (forall x. req x -> req' x) -- ^ The function to map over the request

447+ -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response

448+ -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed

449+ -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'

450+withRequesterT freq frsp child = do

451+ rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'

452+ (a, req) <- lift $ runRequesterT child rsp

453+ rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $

454+ fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req

455+ return a

456+

457+instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

458+ type Request (RequesterT t request response m) = request

459+ type Response (RequesterT t request response m) = response

460+ requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))

461+ requesting_ = void . tagRequest . fmapCheap singleEntry

462+

463+{-# INLINE tagRequest #-}

464+tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))

465+tagRequest req = do

466+ old <- RequesterT get

467+ let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)

468+ t = MyTagWrap n

469+ RequesterT $ put $ RequesterState

470+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

471+ , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old

472+ }

473+ return t

474+

475+{-# INLINE responseFromTag #-}

476+responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

477+responseFromTag (MyTagWrap t) = do

478+ responses :: EventSelectorInt t Any <- RequesterT ask

479+ return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

480+

481+instance MonadTrans (RequesterT t request response) where

482+ lift = RequesterT . lift . lift

483+

484+instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where

485+ type Performable (RequesterT t request response m) = Performable m

486+ performEvent_ = lift . performEvent_

487+ performEvent = lift . performEvent

488+

489+instance MonadRef m => MonadRef (RequesterT t request response m) where

490+ type Ref (RequesterT t request response m) = Ref m

491+ newRef = lift . newRef

492+ readRef = lift . readRef

493+ writeRef r = lift . writeRef r

494+

495+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where

496+ newEventWithTrigger = lift . newEventWithTrigger

497+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

498+

499+instance MonadReader r m => MonadReader r (RequesterT t request response m) where

500+ ask = lift ask

501+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a

502+ reader = lift . reader

503+

504+instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where

505+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

506+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental

507+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

508+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

509+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

510+

511+requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

512+requesting' = responseFromTag . castMyTagWrap <=< tagRequest

513+

514+{-# INLINABLE runWithReplaceRequesterTWith #-}

515+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

516+ , MonadFix m

517+ )

518+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

519+ -> RequesterT t request response m a

520+ -> Event t (RequesterT t request response m b)

521+ -> RequesterT t request response m (a, Event t b)

522+runWithReplaceRequesterTWith f a0 a' = do

523+ rec na' <- numberOccurrencesFrom 1 a'

524+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

525+ let responses' = fanInt responses

526+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'

527+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'

528+ return (result0, fmapCheap (fst . snd) v')

529+

530+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

531+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

532+ ( Reflex t

533+ , MonadHold t m

534+ , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))

535+ , Patch (p (Event t (IntMap (RequesterData request))))

536+ , Functor p

537+ , MonadFix m

538+ )

539+ => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))

540+ -> IntMap (IntMap.Key, v)

541+ -> Event t (p (IntMap.Key, v))

542+ -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))

543+ )

544+ -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))

545+ -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))

546+ -> (IntMap.Key -> v -> RequesterT t request response m v')

547+ -> IntMap v

548+ -> Event t (p v)

549+ -> RequesterT t request response m (IntMap v', Event t (p v'))

550+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

551+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

552+ let responses :: EventSelectorInt t (IntMap (RequesterData response))

553+ responses = fanInt $ fmapCheap unpack response

554+ unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))

555+ unpack = unEntry

556+ pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3

557+ pack = Entry

558+ f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

559+ f' k (n, v) = do

560+ (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?

561+ return (fmapCheap (IntMap.singleton n) myRequests, result)

562+ ndm' <- numberOccurrencesFrom 1 dm'

563+ (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable

564+ let result0 = fmap snd children0

565+ result' = fforCheap children' $ fmap snd

566+ requests0 :: IntMap (Event t (IntMap (RequesterData request)))

567+ requests0 = fmap fst children0

568+ requests' :: Event t (p (Event t (IntMap (RequesterData request))))

569+ requests' = fforCheap children' $ fmap fst

570+ promptRequests :: Event t (IntMap (IntMap (RequesterData request)))

571+ promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

572+ requests <- holdIncremental requests0 requests'

573+ return (result0, result')

574+

575+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

576+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

577+ ( GCompare k

578+ , Reflex t

579+ , MonadHold t m

580+ , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))

581+ , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))

582+ , MonadFix m

583+ )

584+ => (forall k' v1 v2. GCompare k'

585+ => (forall a. k' a -> v1 a -> m (v2 a))

586+ -> DMap k' v1

587+ -> Event t (p k' v1)

588+ -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

589+ )

590+ -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)

591+ -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

592+ -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)

593+ -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

594+ -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

595+ -> DMap k v

596+ -> Event t (p k v)

597+ -> RequesterT t request response m (DMap k v', Event t (p k v'))

598+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

599+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

600+ let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

601+ responses = fanMap $ fmapCheap unpack response

602+ unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

603+ unpack = unEntry

604+ pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

605+ pack = Entry

606+ f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

607+ f' k (Compose (n, v)) = do

608+ (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))

609+ return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

610+ ndm' <- numberOccurrencesFrom 1 dm'

611+ (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

612+ let result0 = DMap.map (snd . getCompose) children0

613+ result' = fforCheap children' $ mapPatch $ snd . getCompose

614+ requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))

615+ requests0 = weakenDMapWith (fst . getCompose) children0

616+ requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))

617+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

618+ promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))

619+ promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

620+ requests <- holdIncremental requests0 requests'

621+ return (result0, result')

622+

623+data Decoder rawResponse response =

624+ forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

625+

626+-- | Matches incoming responses with previously-sent requests

627+-- and uses the provided request "decoder" function to process

628+-- incoming responses.

629+matchResponsesWithRequests

630+ :: forall t rawRequest rawResponse request response m.

631+ ( MonadFix m

632+ , MonadHold t m

633+ , Reflex t

634+ )

635+ => (forall a. request a -> (rawRequest, rawResponse -> response a))

636+ -- ^ Given a request (from 'Requester'), produces the wire format of the

637+ -- request and a function used to process the associated response

638+ -> Event t (RequesterData request)

639+ -- ^ The outgoing requests

640+ -> Event t (Int, rawResponse)

641+ -- ^ The incoming responses, tagged by an identifying key

642+ -> m ( Event t (Map Int rawRequest)

643+ , Event t (RequesterData response)

644+ )

645+ -- ^ A map of outgoing wire-format requests and an event of responses keyed

646+ -- by the 'RequesterData' key of the associated outgoing request

647+matchResponsesWithRequests f send recv = do

648+ rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

649+ waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

650+ holdIncremental mempty $ leftmost

651+ [ fmap (\(_, outstanding, _) -> outstanding) outgoing

652+ , snd <$> incoming

653+ ]

654+ let outgoing = processOutgoing nextId send

655+ incoming = processIncoming waitingFor recv

656+ return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)

657+ where

658+ -- Tags each outgoing request with an identifying integer key

659+ -- and returns the next available key, a map of response decoders

660+ -- for requests for which there are outstanding responses, and the

661+ -- raw requests to be sent out.

662+ processOutgoing

663+ :: Behavior t Int

664+ -- The next available key

665+ -> Event t (RequesterData request)

666+ -- The outgoing request

667+ -> Event t ( Int

668+ , PatchMap Int (Decoder rawResponse response)

669+ , Map Int rawRequest )

670+ -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests

671+ processOutgoing nextId out = flip pushAlways out $ \dm -> do

672+ oldNextId <- sample nextId

673+ let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do

674+ n <- get

675+ put $ succ n

676+ let (rawReq, rspF) = f v

677+ return (n, rawReq, Decoder k rspF)

678+ patchWaitingFor = PatchMap $ Map.fromList $

679+ (\(n, _, dec) -> (n, Just dec)) <$> result

680+ toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result

681+ return (newNextId, patchWaitingFor, toSend)

682+ -- Looks up the each incoming raw response in a map of response

683+ -- decoders and returns the decoded response and a patch that can

684+ -- be used to clear the ID of the consumed response out of the queue

685+ -- of expected responses.

686+ processIncoming

687+ :: Incremental t (PatchMap Int (Decoder rawResponse response))

688+ -- A map of outstanding expected responses

689+ -> Event t (Int, rawResponse)

690+ -- A incoming response paired with its identifying key

691+ -> Event t (RequesterData response, PatchMap Int v)

692+ -- The decoded response and a patch that clears the outstanding responses queue

693+ processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do

694+ wf <- sample $ currentIncremental waitingFor

695+ case Map.lookup n wf of

696+ Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..

697+ Just (Decoder k rspF) -> do

698+ let rsp = rspF rawRsp

699+ return $ Just

700+ ( singletonRequesterData k rsp

701+ , PatchMap $ Map.singleton n Nothing

702+ )

703+-}

src/Reflex/Requester/Class.hs+1−1

@@ -40,7 +40,7 @@ class (Reflex t, Monad m) => Requester t m | m -> t where

4040 requesting :: Event t (Request m a) -> m (Event t (Response m a))

4141 -- | Emit a request whenever the given 'Event' fires, and ignore all responses.

4242 requesting_ :: Event t (Request m a) -> m ()

43−

43+--TODO: Make Requester polykinded, where Request m and Response m both take an argument of the same kind

4444

4545instance Requester t m => Requester t (ReaderT r m) where

4646 type Request (ReaderT r m) = Request m

src/Reflex/Spider/Internal.hs+4−1

@@ -106,6 +106,8 @@ import qualified Data.ByteString.Char8 as BS8

106106import System.IO (stderr)

107107#endif

108108

109+import Debug.Trace

110+

109111#ifdef DEBUG_TRACE_EVENTS

110112

111113withStackOneLine :: (BS8.ByteString -> a) -> a

@@ -1513,13 +1515,14 @@ newFanInt = do

15131515fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

15141516fanInt p = unsafePerformIO $ do

15151517 self <- newFanInt

1516− pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1518+ pure $ EventSelectorInt $ \k -> trace ("select " <> show k) $ Event $ \sub -> do

15171519 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

15181520 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

15191521 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

15201522 { subscriberPropagate = \m -> do

15211523 liftIO $ writeIORef (_fanInt_occRef self) m

15221524 scheduleIntClear $ _fanInt_occRef self

1525+ liftIO $ putStrLn $ "Pushing " <> show (IntMap.size m) <> " occurrences"

15231526 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?

15241527 FastWeakBag.traverse b $ \s -> do

15251528 subscriberPropagate s v

test/EventWriterT.hs+15−11

@@ -24,26 +24,30 @@ import Test.Run

2424

2525main :: IO ()

2626main = do

27− os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $

27+ os1 <- runApp' (unwrapApp testOrdering) $

2828 [ Just ()

2929 ]

3030 print os1

31− os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]

32− <- runApp' (unwrapApp testSimultaneous) $ map Just $

33− [ This ()

34− , That ()

35− , This ()

36− , These () ()

37− ]

31+ os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $

32+ [ This ()

33+ , That ()

34+ , This ()

35+ , These () ()

36+ ]

3837 print os2

39− os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]

38+ os3 <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]

4039 print os3

41− os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]

40+ os4 <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]

4241 print os4

43− os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]

42+ os5 <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]

4443 print os5

4544 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

4645 print os6

46+ let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1

47+ let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2

48+ let ![[Nothing, Just [2]]] = os3

49+ let ![[Nothing, Just [2]]] = os4

50+ let ![[Nothing, Just [1, 2]]] = os5

4751 let ![[Nothing, Nothing]] = os6

4852 return ()

4953

test/RequesterT.hs+31−26

@@ -10,11 +10,13 @@ module Main where

1010import Control.Lens

1111import Control.Monad

1212import Control.Monad.Fix

13+import Control.Monad.Primitive

1314import qualified Data.Dependent.Map as DMap

1415import Data.Dependent.Sum

1516import Data.Functor.Misc

1617import qualified Data.Map as M

1718import Data.These

19+import Data.Foldable

1820

1921#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

2022import Data.These.Lens

@@ -30,43 +32,46 @@ data RequestInt a where

3032

3133main :: IO ()

3234main = do

33− os1 <- runApp' (unwrapApp testOrdering) $

34− [ Just ()

35− ]

36− print os1

37− os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $

38− [ This ()

39− , That ()

40− , This ()

41− , These () ()

42− ]

43− print os2

44− os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]

45− print os3

35+-- os1 <- runApp' (unwrapApp testOrdering) $

36+-- [ Just ()

37+-- ]

38+-- print os1

39+-- os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $

40+-- [ This ()

41+-- , That ()

42+-- , This ()

43+-- , These () ()

44+-- ]

45+-- print os2

46+-- os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]

47+-- print os3

4648 os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()]

4749 print os4

48− os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]

49− print os5

50− os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

51− print os6

52− let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'

53− let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2

54− let ![[Nothing, Just [2]]] = os3

50+-- os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]

51+-- print os5

52+-- os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

53+-- print os6

54+-- let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1

55+-- let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2

56+-- let ![[Nothing, Just [2]]] = os3

5557 let ![[Nothing, Just [2]]] = os4

56− let ![[Nothing, Just [1, 2]]] = os5

58+-- let ![[Nothing, Just [1, 2]]] = os5

5759 -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved

5860 return ()

5961

60−unwrapRequest :: DSum tag RequestInt -> Int

61−unwrapRequest (_ :=> RequestInt i) = i

62−

63−unwrapApp :: ( Reflex t, Monad m )

62+unwrapApp :: forall t m a.

63+ ( Reflex t

64+ , MonadFix m

65+ , PrimMonad m

66+ )

6467 => (a -> RequesterT t RequestInt Identity m ())

6568 -> a

6669 -> m (Event t [Int])

6770unwrapApp x appIn = do

6871 ((), e) <- runRequesterT (x appIn) never

69− return $ fmap (map unwrapRequest . requesterDataToList) e

72+ let unwrapRequests :: forall x. RequestData (PrimState m) RequestInt -> [Int]

73+ unwrapRequests (RequestData _ es) = fmap (\(RequestEnvelope _ (RequestInt i)) -> i) $ toList es

74+ return $ fmap unwrapRequests e

7075

7176testOrdering :: ( Response m ~ Identity

7277 , Request m ~ RequestInt