develop...d3a3059 · reflex

git.iko.soy/reflex

18 files changed+1066−699

since splitsnapshots

unifiedsplit

default.nix−43 reflex.cabal+17−4 src/Data/List/NonEmpty/Deferred.hs+30 src/Data/TagMap.hs+39 src/Data/Unique/Tag/Local.hs+11 src/Data/Unique/Tag/Local/Internal.hs+59 src/Reflex/Class.hs+30−14 src/Reflex/Dynamic.hs+1 src/Reflex/EventWriter/Base.hs+9−51 src/Reflex/FanTag.hs+23 src/Reflex/NotReady/Class.hs+5 src/Reflex/Patch/IntMap.hs+19−8 src/Reflex/PerformEvent/Base.hs+88−12 src/Reflex/Requester/Base.hs+14−529 src/Reflex/Requester/Base/Internal.hs+674 src/Reflex/Requester/Class.hs+1−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+17−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,

@@ -90,13 +91,17 @@ library

9091 Data.FastMutableIntMap,

9192 Data.FastWeakBag,

9293 Data.Functor.Misc,

94+ Data.List.NonEmpty.Deferred,

9395 Data.Map.Misc,

96+ Data.TagMap,

97+ Data.Unique.Tag.Local,

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

9499 Data.WeakBag,

95100 Reflex,

96− Reflex.Class,

97101 Reflex.Adjustable.Class,

98102 Reflex.BehaviorWriter.Base,

99103 Reflex.BehaviorWriter.Class,

104+ Reflex.Class,

100105 Reflex.Collection,

101106 Reflex.Dynamic,

102107 Reflex.Dynamic.Uniq,

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

106111 Reflex.EventWriter,

107112 Reflex.EventWriter.Base,

108113 Reflex.EventWriter.Class,

114+ Reflex.FanTag,

109115 Reflex.FastWeak,

110116 Reflex.FunctorMaybe,

111117 Reflex.Host.Class,

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

127133 Reflex.Query.Base,

128134 Reflex.Query.Class,

129135 Reflex.Requester.Base,

136+ Reflex.Requester.Base.Internal,

130137 Reflex.Requester.Class,

131138 Reflex.Spider,

132139 Reflex.Spider.Internal,

@@ -137,6 +144,7 @@ library

137144 Reflex.Workflow

138145

139146 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively

147+ ghc-prof-options: -fprof-auto-calls

140148

141149 if flag(debug-trace-events)

142150 cpp-options: -DDEBUG_TRACE_EVENTS

@@ -172,6 +180,7 @@ test-suite semantics

172180 main-is: semantics.hs

173181 hs-source-dirs: test

174182 ghc-options: -O2 -Wall -rtsopts

183+ ghc-prof-options: -fprof-auto-calls

175184 build-depends:

176185 base,

177186 bifunctors,

@@ -197,6 +206,7 @@ test-suite CrossImpl

197206 main-is: Reflex/Test/CrossImpl.hs

198207 hs-source-dirs: test

199208 ghc-options: -O2 -Wall -rtsopts

209+ ghc-prof-options: -fprof-auto-calls

200210 build-depends:

201211 base,

202212 containers,

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

259269 build-depends: base

260270 , containers

261271 , deepseq

262− , dependent-sum

263272 , dependent-map

273+ , dependent-sum

264274 , lens

265275 , mtl

276+ , primitive

277+ , ref-tf

278+ , reflex

266279 , these

267280 , transformers

268− , reflex

269− , ref-tf

270281

271282 if flag(split-these)

272283 build-depends: these-lens

@@ -348,6 +359,7 @@ benchmark spider-bench

348359 hs-source-dirs: bench test

349360 main-is: Main.hs

350361 ghc-options: -Wall -O2 -rtsopts

362+ ghc-prof-options: -fprof-auto-calls

351363 build-depends:

352364 base,

353365 containers,

@@ -373,6 +385,7 @@ benchmark saulzar-bench

373385 c-sources: bench-cbits/checkCapability.c

374386 main-is: RunAll.hs

375387 ghc-options: -Wall -O2 -rtsopts -threaded

388+ ghc-prof-options: -fprof-auto-calls

376389 build-depends:

377390 base,

378391 containers,

src/Data/List/NonEmpty/Deferred.hsnew file+30

@@ -0,0 +1,30 @@

1+-- | Uses a non-associative internal structure to represent a NonEmpty list, but

2+-- prevents external observers from observing the non-associativity. This

3+-- allows O(1) '(<>)'.

5+{-# LANGUAGE LambdaCase #-}

6+module Data.List.NonEmpty.Deferred

7+ ( NonEmptyDeferred

8+ , singleton

9+ , toNonEmpty

10+ ) where

11+

12+import Data.List.NonEmpty (NonEmpty (..))

13+import qualified Data.List.NonEmpty as NonEmpty

14+

15+data NonEmptyDeferred a

16+ = NonEmptyDeferred_Singleton a

17+ | NonEmptyDeferred_Append !(NonEmptyDeferred a) !(NonEmptyDeferred a)

18+

19+singleton :: a -> NonEmptyDeferred a

20+singleton = NonEmptyDeferred_Singleton

21+

22+{-# INLINE toNonEmpty #-}

23+toNonEmpty :: NonEmptyDeferred a -> NonEmpty a

24+toNonEmpty = go []

25+ where go t = \case

26+ NonEmptyDeferred_Singleton a -> a :| t

27+ NonEmptyDeferred_Append a b -> go (NonEmpty.toList $ go t b) a

28+

29+instance Semigroup (NonEmptyDeferred a) where

30+ (<>) = NonEmptyDeferred_Append

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/Class.hs+30−14

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

169169 , tagCheap

170170 , mergeWithCheap

171171 , mergeWithCheap'

172+ , sconcatCheap

172173 -- * Slow, but general, implementations

173174 , slowHeadE

174175 ) where

@@ -890,6 +891,9 @@ instance (Semigroup a, Reflex t) => Semigroup (Event t a) where

890891 sconcat = fmap sconcat . mergeList . toList

891892 stimes n = fmap $ stimes n

892893

894+sconcatCheap :: (Semigroup a, Reflex t) => NonEmpty (Event t a) -> Event t a

895+sconcatCheap = fmapCheap sconcat . mergeList . toList

896+

893897instance (Semigroup a, Reflex t) => Monoid (Event t a) where

894898 mempty = never

895899 mappend = (<>)

@@ -904,6 +908,8 @@ mergeWith = mergeWith' id

904908

905909{-# INLINE mergeWith' #-}

906910mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

911+mergeWith' _ _ [] = never

912+mergeWith' f _ [e] = fmap f e

907913mergeWith' f g es = fmap (Prelude.foldl1 g . fmap f)

908914 . mergeInt

909915 . IntMap.fromDistinctAscList

@@ -921,6 +927,7 @@ leftmost = mergeWith const

921927-- time.

922928mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)

923929mergeList [] = never

930+mergeList [e] = fmapCheap (:|[]) e

924931mergeList es = mergeWithFoldCheap' id es

925932

926933unsafeMapIncremental

@@ -937,10 +944,6 @@ unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIn

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

938945mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

939946

940−-- | Like 'mergeMap' but for 'IntMap'.

941−mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

942−mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap

943−

944947-- | Create a merge whose parents can change over time

945948mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)

946949mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)

@@ -1017,23 +1020,27 @@ switchHoldPromptly ea0 eea = do

10171020switchHoldPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

10181021switchHoldPromptOnly e0 e' = do

10191022 eLag <- switch <$> hold e0 e'

1020− return $ coincidence $ leftmost [e', eLag <$ eLag]

1023+ return $ fmapMaybeCheap id $ leftmost

1024+ [ fmapCheap Just $ coincidence e'

1025+ , fmapCheap (const Nothing) e'

1026+ , fmapCheap Just eLag

1027+ ]

10211028

10221029-- | When the given outer event fires, condense the inner events into the contained patch. Non-firing inner events will be replaced with deletions.

10231030coincidencePatchMap :: (Reflex t, Ord k) => Event t (PatchMap k (Event t v)) -> Event t (PatchMap k v)

1024−coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m) -> mergeMap $ ffor m $ \case

1031+coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ fforCheap e $ \(PatchMap m) -> mergeMap $ ffor m $ \case

10251032 Nothing -> fmapCheap (const Nothing) e

10261033 Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]

10271034

10281035-- | See 'coincidencePatchMap'

10291036coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v)

1030−coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case

1037+coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ fforCheap e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case

10311038 Nothing -> fmapCheap (const Nothing) e

10321039 Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]

10331040

10341041-- | See 'coincidencePatchMap'

10351042coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v)

1036−coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of

1043+coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ fforCheap e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of

10371044 PatchMapWithMove.From_Delete -> fforCheap e $ \_ ->

10381045 ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }

10391046 PatchMapWithMove.From_Move k -> fforCheap e $ \_ ->

@@ -1293,7 +1300,7 @@ accumMaybeMDyn

12931300 -> Event t b

12941301 -> m (Dynamic t a)

12951302accumMaybeMDyn f z e = do

1296− rec let e' = flip push e $ \o -> do

1303+ rec let e' = flip pushCheap e $ \o -> do

12971304 v <- sample $ current d'

12981305 f v o

12991306 d' <- holdDyn z e'

@@ -1349,8 +1356,8 @@ mapAccumMaybeMDyn f z e = do

13491356 return $ case result of

13501357 (Nothing, Nothing) -> Nothing

13511358 _ -> Just result

1352− d' <- holdDyn z $ mapMaybe fst e'

1353− return (d', mapMaybe snd e')

1359+ d' <- holdDyn z $ fmapMaybeCheap fst e'

1360+ return (d', fmapMaybeCheap snd e')

13541361

13551362-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'

13561363-- with the provided function.

@@ -1388,7 +1395,7 @@ accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o

13881395{-# INLINE accumMaybeMB #-}

13891396accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)

13901397accumMaybeMB f z e = do

1391− rec let e' = flip push e $ \o -> do

1398+ rec let e' = flip pushCheap e $ \o -> do

13921399 v <- sample d'

13931400 f v o

13941401 d' <- hold z e'

@@ -1438,8 +1445,8 @@ mapAccumMaybeMB f z e = do

14381445 return $ case result of

14391446 (Nothing, Nothing) -> Nothing

14401447 _ -> Just result

1441− d' <- hold z $ mapMaybe fst e'

1442− return (d', mapMaybe snd e')

1448+ d' <- hold z $ fmapMaybeCheap fst e'

1449+ return (d', fmapMaybeCheap snd e')

14431450

14441451-- | Accumulate occurrences of an 'Event', producing an output occurrence each

14451452-- time. Discard the underlying 'Accumulator'.

@@ -1649,6 +1656,8 @@ mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f

16491656-- | A "cheap" version of 'mergeWithFoldCheap''. See the performance note on 'pushCheap'.

16501657{-# INLINE mergeWithFoldCheap' #-}

16511658mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b

1659+mergeWithFoldCheap' f [] = never

1660+mergeWithFoldCheap' f [e] = fmapCheap (f . (:|[])) e

16521661mergeWithFoldCheap' f es =

16531662 fmapCheap (f . (\(h : t) -> h :| t) . IntMap.elems)

16541663 . mergeInt

@@ -1663,7 +1672,14 @@ mergeWithFoldCheap' f es =

16631672-- | See 'switchHoldPromptly'

16641673switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

16651674switchPromptly = switchHoldPromptly

1675+

16661676{-# DEPRECATED switchPromptOnly "Use 'switchHoldPromptOnly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}

16671677-- | See 'switchHoldPromptOnly'

16681678switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

16691679switchPromptOnly = switchHoldPromptOnly

1680+

1681+{-# DEPRECATED mergeIntMap "Use 'mergeInt' instead" #-}

1682+-- | Like 'mergeMap' but for 'IntMap'.

1683+mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

1684+mergeIntMap = mergeInt

1685+

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+9−51

@@ -47,6 +47,8 @@ import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))

4747import Data.IntMap.Strict (IntMap)

4848import qualified Data.IntMap.Strict as IntMap

4949import Data.List.NonEmpty (NonEmpty (..))

50+import Data.List.NonEmpty.Deferred (NonEmptyDeferred)

51+import qualified Data.List.NonEmpty.Deferred as NonEmptyDeferred

5052import Data.Map (Map)

5153import qualified Data.Map as Map

5254import Data.Semigroup

@@ -54,45 +56,7 @@ import Data.Some (Some)

5456import Data.Tuple

5557import Data.Type.Equality

5658

57−import Unsafe.Coerce

58−

59−{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}

60−newtype TellId w x

61− = TellId Int -- ^ WARNING: Do not construct this directly; use 'tellId' instead

62− deriving (Show, Eq, Ord, Enum)

63−

64−tellId :: Int -> TellId w w

65−tellId = TellId

66−{-# INLINE tellId #-}

67−

68−tellIdRefl :: TellId w x -> w :~: x

69−tellIdRefl _ = unsafeCoerce Refl

70−

71−withTellIdRefl :: TellId w x -> (w ~ x => r) -> r

72−withTellIdRefl tid r = case tellIdRefl tid of

73− Refl -> r

74−

75−instance GEq (TellId w) where

76− a `geq` b =

77− withTellIdRefl a $

78− withTellIdRefl b $

79− if a == b

80− then Just Refl

81− else Nothing

82−

83−instance GCompare (TellId w) where

84− a `gcompare` b =

85− withTellIdRefl a $

86− withTellIdRefl b $

87− case a `compare` b of

88− LT -> GLT

89− EQ -> GEQ

90− GT -> GGT

91−

92−data EventWriterState t w = EventWriterState

93− { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)

94− , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order

95− }

59+type EventWriterState t w = Maybe (NonEmptyDeferred (Event t w))

9660

9761-- | A basic implementation of 'EventWriter'.

9862newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }

@@ -101,20 +65,11 @@ newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWri

10165-- | Run a 'EventWriterT' action.

10266runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

10367runEventWriterT (EventWriterT a) = do

104− (result, requests) <- runStateT a $ EventWriterState (-1) []

105− let combineResults :: DMap (TellId w) Identity -> w

106− combineResults = sconcat

107− . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps

108− . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order

109− return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help

68+ (result, requests) <- runStateT a Nothing

69+ return (result, maybe never (sconcatCheap . NonEmptyDeferred.toNonEmpty) requests)

11070

11171instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where

112− tellEvent w = EventWriterT $ modify $ \old ->

113− let myId = _eventWriterState_nextId old

114− in EventWriterState

115− { _eventWriterState_nextId = pred myId

116− , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old

117− }

72+ tellEvent w = EventWriterT $ modify (<> Just (NonEmptyDeferred.singleton w))

11873

11974instance MonadTrans (EventWriterT t w) where

12075 lift = EventWriterT . lift

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

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

201156 return (result0, result')

202157

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

159+switchHoldPromptOnlyIntMapIncremental = switchHoldPromptOnlyIncremental mergeIntIncremental coincidencePatchIntMap

160+

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

204162sequenceDMapWithAdjustEventWriterTWith

205163 :: 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+88−12

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

50+import Data.List.NonEmpty (NonEmpty (..))

51+import Data.List.NonEmpty.Deferred (NonEmptyDeferred)

52+import qualified Data.List.NonEmpty.Deferred as NonEmptyDeferred

53+import Data.Map (Map)

54+import qualified Data.Map as Map

55+import Data.Semigroup (Semigroup (sconcat))

4656import qualified Data.Semigroup as S

57+import Data.Unique.Tag.Local

58+import Data.Sequence (Seq)

59+import Data.Tuple

60+import qualified Data.TagMap as TagMap

4761

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

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

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

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

6983 primitive = PerformEventT . lift . primitive

7084

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

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

7286 type Performable (PerformEventT t m) = HostFrame t

7387 {-# INLINABLE performEvent_ #-}

7488 performEvent_ = PerformEventT . requesting_

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

7690 performEvent = PerformEventT . requestingIdentity

7791

7892instance (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')

93+ {-# INLINE runWithReplace #-}

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

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

96+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))

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

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

99+ newA <- requestingIdentity $ runA <$> a'

100+ requests <- switchHoldPromptOnly requests0 $ fmapCheap snd newA

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

102+ RequesterInternalT $ tellEvent requests

103+ pure (result0, fmapCheap fst newA)

104+ {-# INLINE traverseIntMapWithKeyWithAdjust #-}

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

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

107+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))

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

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

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

111+ let results0 = fmap fst children0

112+ requests0 = fmap snd children0

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

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

115+ requests <- switchHoldPromptOnlyIncremental mergeIntIncremental coincidencePatchIntMap requests0 requests'

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

117+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatIntMapMaybe

118+ pure (results0, results')

119+ {-# INLINE traverseDMapWithKeyWithAdjust #-}

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

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

122+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)

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

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

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

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

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

128+ requests0 = weakenDMapWith (fst . getCompose) children0

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

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

131+ requests <- switchHoldPromptOnlyIncremental mergeMapIncremental coincidencePatchMap requests0 requests'

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

133+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe

134+ pure (results0, results')

135+ {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}

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

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

138+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)

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

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

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

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

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

144+ requests0 = weakenDMapWith (fst . getCompose) children0

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

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

147+ requests <- switchHoldPromptOnlyIncremental mergeMapIncrementalWithMove coincidencePatchMapWithMove requests0 requests'

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

149+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe

150+ pure (results0, results')

151+

152+concatIntMapMaybe :: Semigroup a => IntMap a -> Maybe a

153+concatIntMapMaybe m = case IntMap.elems m of

154+ [] -> Nothing

155+ h : t -> Just $ sconcat $ h :| t

156+

157+concatMapMaybe :: Semigroup a => Map k a -> Maybe a

158+concatMapMaybe m = case Map.elems m of

159+ [] -> Nothing

160+ h : t -> Just $ sconcat $ h :| t

88161

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

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

@@ -124,6 +197,7 @@ hostPerformEventT :: forall t m a.

124197 , MonadReflexHost t m

125198 , MonadRef m

126199 , Ref m ~ Ref IO

200+ , PrimMonad (HostFrame t)

127201 )

128202 => PerformEventT t m a

129203 -> m (a, FireCommand t m)

@@ -142,6 +216,8 @@ hostPerformEventT a = do

142216 Nothing -> return [result']

143217 Just toPerform -> do

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

219+ let responseLength = case responses of

220+ ResponseData _ m -> TagMap.size m

145221 mrt <- readRef responseTrigger

146222 let followupEventTriggers = case mrt of

147223 Just rt -> [rt :=> Identity responses]

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

@@ -0,0 +1,674 @@

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 qualified Data.List.NonEmpty as NonEmpty

49+import Data.List.NonEmpty.Deferred (NonEmptyDeferred)

50+import qualified Data.List.NonEmpty.Deferred as NonEmptyDeferred

51+import Data.Map (Map)

52+import qualified Data.Map as Map

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

54+import Data.Proxy

55+import qualified Data.Semigroup as S

56+import Data.Some (Some(Some))

57+import Data.Type.Equality

58+import Data.Sequence (Seq)

59+import qualified Data.Sequence as Seq

60+import Data.TagMap (TagMap)

61+import qualified Data.TagMap as TagMap

62+import Reflex.FanTag

63+import Data.Unique.Tag.Local

64+import qualified Data.Unique.Tag as Global

65+import Data.GADT.Compare

66+import Data.Witherable

67+import Data.Foldable

68+

69+import Unsafe.Coerce

70+

71+import Debug.Trace

72+

73+data RequestData ps request = forall s. RequestData !(TagGen ps s) !(NonEmptyDeferred (RequestEnvelope s request))

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

75+

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

77+traverseRequesterData f (RequestData tg es) = ResponseData tg . TagMap.fromList <$> wither g (NonEmpty.toList $ NonEmptyDeferred.toNonEmpty es)

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

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

80+ Nothing -> Nothing <$ f req

81+

82+runRequesterT :: forall t request response m a

83+ . ( Reflex t

84+ , PrimMonad m

85+ , MonadFix m

86+ )

87+ => RequesterT t request response m a

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

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

90+runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \requests -> do

91+ (_, tg) <- RequesterInternalT ask

92+ result <- a

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

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

95+ Just Refl -> Just m

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

97+

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

99+ lift = RequesterInternalT . lift . lift

100+

101+instance MonadTrans (RequesterT t request response) where

102+ lift a = RequesterT $ RequesterInternalT $ lift $ lift a

103+

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

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

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

107+-- requests were issued.

108+withRequesterInternalT

109+ :: forall t m request response a.

110+ ( Reflex t

111+ , PrimMonad m

112+ , MonadFix m

113+ )

114+ => (Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom request)) -> RequesterInternalT FakeRequesterStatePhantom t request response m (Event t (TagMap FakeRequesterStatePhantom response), a))

115+ -> m a

116+withRequesterInternalT f = do

117+ stg <- newTagGen

118+ let tg = case stg of

119+ Some tg' -> (unsafeCoerce :: TagGen (PrimState m) s -> TagGen (PrimState m) FakeRequesterStatePhantom) tg'

120+ rec let RequesterInternalT a = (unsafeCoerce :: RequesterInternalT s t request response m (Event t (TagMap FakeRequesterStatePhantom response), a) -> RequesterInternalT FakeRequesterStatePhantom t request response m (Event t (TagMap FakeRequesterStatePhantom response), a)) $ f requests

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

122+ pure result

123+

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

125+

126+-- This is because using forall ruins inlining

127+data FakeRequesterStatePhantom

128+

129+newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: RequesterInternalT FakeRequesterStatePhantom t request response m a }

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

131+

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

133+ deriving

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

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

136+ , MonadAsyncException

137+#endif

138+ )

139+

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

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

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

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

144+-- #endif

145+

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

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

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

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

150+

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

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

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

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

155+

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

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

158+ primitive = lift . primitive

159+

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

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

162+ mempty = pure mempty

163+ mappend = liftA2 mappend

164+

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

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

167+

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

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

170+ performEvent_ = lift . performEvent_

171+ performEvent = lift . performEvent

172+

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

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

175+ newRef = lift . newRef

176+ readRef = lift . readRef

177+ writeRef r = lift . writeRef r

178+

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

180+ newEventWithTrigger = lift . newEventWithTrigger

181+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

182+

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

184+ ask = lift ask

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

186+ reader = lift . reader

187+

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

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

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

191+ requesting e = RequesterT $ requesting e

192+ requesting_ e = RequesterT $ requesting_ e

193+

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

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

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

197+ requesting e = RequesterInternalT $ do

198+ (s, tg) <- ask

199+ t <- lift $ lift $ newTag tg

200+ tellEvent $ fmapCheap (NonEmptyDeferred.singleton . RequestEnvelope (Just t)) e

201+ pure $ selectTag s t

202+ requesting_ e = RequesterInternalT $ do

203+ tellEvent $ fmapCheap (NonEmptyDeferred.singleton . RequestEnvelope Nothing) e

204+

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

206+ {-# INLINE runWithReplace #-}

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

208+ {-# INLINE traverseIntMapWithKeyWithAdjust #-}

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

210+ {-# INLINE traverseDMapWithKeyWithAdjust #-}

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

212+ {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}

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

214+

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

216+ {-# INLINE runWithReplace #-}

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

218+ {-# INLINE traverseIntMapWithKeyWithAdjust #-}

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

220+ {-# INLINE traverseDMapWithKeyWithAdjust #-}

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

222+ {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}

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

224+

225+{-

226+import GHC.Exts (Any)

227+import Unsafe.Coerce

228+

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

230+

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

232+

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

234+

235+data RequesterDataKey a where

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

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

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

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

240+

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

242+singletonRequesterData rdk v = case rdk of

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

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

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

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

247+

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

249+requesterDataToList (RequesterData m) = do

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

251+ case myKeyType k of

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

253+ MyTagType_Multi -> do

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

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

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

257+ MyTagType_Multi2 -> do

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

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

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

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

262+ MyTagType_Multi3 -> do

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

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

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

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

267+

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

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

270+

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

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

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

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

275+

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

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

278+ where

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

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

281+

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

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

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

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

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

287+ MyTagType_Single -> f request

288+ MyTagType_Multi -> traverse (traverseRequesterData f) request

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

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

291+

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

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

294+forRequesterData r f = traverseRequesterData f r

295+

296+data MyTagType :: * -> * where

297+ MyTagType_Single :: MyTagType (Single a)

298+ MyTagType_Multi :: MyTagType Multi

299+ MyTagType_Multi2 :: MyTagType (Multi2 k)

300+ MyTagType_Multi3 :: MyTagType Multi3

301+

302+myKeyType :: MyTag x -> MyTagType x

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

304+ 0x0 -> unsafeCoerce MyTagType_Single

305+ 0x1 -> unsafeCoerce MyTagType_Multi

306+ 0x2 -> unsafeCoerce MyTagType_Multi2

307+ 0x3 -> unsafeCoerce MyTagType_Multi3

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

309+

310+data Single a

311+data Multi

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

313+data Multi3

314+

315+class MyTagTypeOffset x where

316+ myTagTypeOffset :: proxy x -> Int

317+

318+instance MyTagTypeOffset (Single a) where

319+ myTagTypeOffset _ = 0x0

320+

321+instance MyTagTypeOffset Multi where

322+ myTagTypeOffset _ = 0x1

323+

324+instance MyTagTypeOffset (Multi2 k) where

325+ myTagTypeOffset _ = 0x2

326+

327+instance MyTagTypeOffset Multi3 where

328+ myTagTypeOffset _ = 0x3

329+

330+type family EntryContents request a where

331+ EntryContents request (Single a) = request a

332+ EntryContents request Multi = IntMap (RequesterData request)

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

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

335+

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

337+

338+{-# INLINE singleEntry #-}

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

340+singleEntry = Entry

341+

342+{-# INLINE multiEntry #-}

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

344+multiEntry = Entry

345+

346+{-# INLINE unMultiEntry #-}

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

348+unMultiEntry = unEntry

349+

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

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

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

353+

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

355+

356+{-# INLINE castMyTagWrap #-}

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

358+castMyTagWrap = coerce

359+

360+instance GEq MyTag where

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

362+ if a == b

363+ then Just $ unsafeCoerce Refl

364+ else Nothing

365+

366+instance GCompare MyTag where

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

368+ case a `compare` b of

369+ LT -> GLT

370+ EQ -> unsafeCoerce GEQ

371+ GT -> GGT

372+

373+instance GEq (MyTagWrap f) where

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

375+ if a == b

376+ then Just $ unsafeCoerce Refl

377+ else Nothing

378+

379+instance GCompare (MyTagWrap f) where

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

381+ case a `compare` b of

382+ LT -> GLT

383+ EQ -> unsafeCoerce GEQ

384+ GT -> GGT

385+

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

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

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

389+ }

390+

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

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

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

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

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

396+ , MonadAsyncException

397+#endif

398+ )

399+

400+

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

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

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

404+-- requests were issued.

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

406+ => RequesterT t request response m a

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

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

409+runRequesterT (RequesterT a) responses = do

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

411+ coerceEvent responses

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

413+

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

415+withRequesterT

416+ :: (Reflex t, MonadFix m)

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

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

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

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

421+withRequesterT freq frsp child = do

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

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

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

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

426+ return a

427+

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

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

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

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

432+ requesting_ = void . tagRequest . fmapCheap singleEntry

433+

434+{-# INLINE tagRequest #-}

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

436+tagRequest req = do

437+ old <- RequesterT get

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

439+ t = MyTagWrap n

440+ RequesterT $ put $ RequesterState

441+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

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

443+ }

444+ return t

445+

446+{-# INLINE responseFromTag #-}

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

448+responseFromTag (MyTagWrap t) = do

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

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

451+

452+instance MonadTrans (RequesterT t request response) where

453+ lift = RequesterT . lift . lift

454+

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

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

457+ performEvent_ = lift . performEvent_

458+ performEvent = lift . performEvent

459+

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

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

462+ newRef = lift . newRef

463+ readRef = lift . readRef

464+ writeRef r = lift . writeRef r

465+

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

467+ newEventWithTrigger = lift . newEventWithTrigger

468+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

469+

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

471+ ask = lift ask

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

473+ reader = lift . reader

474+

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

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

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

478+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

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

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

481+

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

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

484+

485+{-# INLINABLE runWithReplaceRequesterTWith #-}

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

487+ , MonadFix m

488+ )

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

490+ -> RequesterT t request response m a

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

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

493+runWithReplaceRequesterTWith f a0 a' = do

494+ rec na' <- numberOccurrencesFrom 1 a'

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

496+ let responses' = fanInt responses

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

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

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

500+

501+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

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

503+ ( Reflex t

504+ , MonadHold t m

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

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

507+ , Functor p

508+ , MonadFix m

509+ )

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

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

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

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

514+ )

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

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

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

518+ -> IntMap v

519+ -> Event t (p v)

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

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

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

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

524+ responses = fanInt $ fmapCheap unpack response

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

526+ unpack = unEntry

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

528+ pack = Entry

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

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

531+ (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?

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

533+ ndm' <- numberOccurrencesFrom 1 dm'

534+ (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

535+ let result0 = fmap snd children0

536+ result' = fforCheap children' $ fmap snd

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

538+ requests0 = fmap fst children0

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

540+ requests' = fforCheap children' $ fmap fst

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

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

543+ requests <- holdIncremental requests0 requests'

544+ return (result0, result')

545+

546+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

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

548+ ( GCompare k

549+ , Reflex t

550+ , MonadHold t m

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

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

553+ , MonadFix m

554+ )

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

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

557+ -> DMap k' v1

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

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

560+ )

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

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

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

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

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

566+ -> DMap k v

567+ -> Event t (p k v)

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

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

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

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

572+ responses = fanMap $ fmapCheap unpack response

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

574+ unpack = unEntry

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

576+ pack = Entry

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

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

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

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

581+ ndm' <- numberOccurrencesFrom 1 dm'

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

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

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

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

586+ requests0 = weakenDMapWith (fst . getCompose) children0

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

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

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

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

591+ requests <- holdIncremental requests0 requests'

592+ return (result0, result')

593+

594+data Decoder rawResponse response =

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

596+

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

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

599+-- incoming responses.

600+matchResponsesWithRequests

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

602+ ( MonadFix m

603+ , MonadHold t m

604+ , Reflex t

605+ )

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

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

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

609+ -> Event t (RequesterData request)

610+ -- ^ The outgoing requests

611+ -> Event t (Int, rawResponse)

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

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

614+ , Event t (RequesterData response)

615+ )

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

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

618+matchResponsesWithRequests f send recv = do

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

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

621+ holdIncremental mempty $ leftmost

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

623+ , snd <$> incoming

624+ ]

625+ let outgoing = processOutgoing nextId send

626+ incoming = processIncoming waitingFor recv

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

628+ where

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

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

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

632+ -- raw requests to be sent out.

633+ processOutgoing

634+ :: Behavior t Int

635+ -- The next available key

636+ -> Event t (RequesterData request)

637+ -- The outgoing request

638+ -> Event t ( Int

639+ , PatchMap Int (Decoder rawResponse response)

640+ , Map Int rawRequest )

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

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

643+ oldNextId <- sample nextId

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

645+ n <- get

646+ put $ succ n

647+ let (rawReq, rspF) = f v

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

649+ patchWaitingFor = PatchMap $ Map.fromList $

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

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

652+ return (newNextId, patchWaitingFor, toSend)

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

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

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

656+ -- of expected responses.

657+ processIncoming

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

659+ -- A map of outstanding expected responses

660+ -> Event t (Int, rawResponse)

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

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

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

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

665+ wf <- sample $ currentIncremental waitingFor

666+ case Map.lookup n wf of

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

668+ Just (Decoder k rspF) -> do

669+ let rsp = rspF rawRsp

670+ return $ Just

671+ ( singletonRequesterData k rsp

672+ , PatchMap $ Map.singleton n Nothing

673+ )

674+-}

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

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