develop...677ce27 · reflex

git.iko.soy/reflex

18 files changed+1088−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+84−12 src/Reflex/Requester/Base.hs+14−529 src/Reflex/Requester/Base/Internal.hs+700 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+84−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,70 @@ 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+ runWithReplace a0 a' = PerformEventT $ RequesterT $ do

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

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

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

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

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

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

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

101+ RequesterInternalT $ tellEvent requests

102+ pure (result0, fmapCheap fst newA)

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

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

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

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

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

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

109+ let results0 = fmap fst children0

110+ requests0 = fmap snd children0

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

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

113+ requests <- switchHoldPromptOnlyIncremental mergeIntIncremental coincidencePatchIntMap requests0 requests'

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

115+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatIntMapMaybe

116+ pure (results0, results')

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

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

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

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

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

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

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

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

125+ requests0 = weakenDMapWith (fst . getCompose) children0

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

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

128+ requests <- switchHoldPromptOnlyIncremental mergeMapIncremental coincidencePatchMap requests0 requests'

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

130+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe

131+ pure (results0, results')

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

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

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

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

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

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

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

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

140+ requests0 = weakenDMapWith (fst . getCompose) children0

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

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

143+ requests <- switchHoldPromptOnlyIncremental mergeMapIncrementalWithMove coincidencePatchMapWithMove requests0 requests'

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

145+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe

146+ pure (results0, results')

147+

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

149+concatIntMapMaybe m = case IntMap.elems m of

150+ [] -> Nothing

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

152+

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

154+concatMapMaybe m = case Map.elems m of

155+ [] -> Nothing

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

88157

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

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

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

124193 , MonadReflexHost t m

125194 , MonadRef m

126195 , Ref m ~ Ref IO

196+ , PrimMonad (HostFrame t)

127197 )

128198 => PerformEventT t m a

129199 -> m (a, FireCommand t m)

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

142212 Nothing -> return [result']

143213 Just toPerform -> do

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

215+ let responseLength = case responses of

216+ ResponseData _ m -> TagMap.size m

145217 mrt <- readRef responseTrigger

146218 let followupEventTriggers = case mrt of

147219 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+700

@@ -0,0 +1,700 @@

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 Debug.Trace

70+

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

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

73+

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

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

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

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

78+ Nothing -> Nothing <$ f req

79+

80+runRequesterT :: forall t request response m a

81+ . ( Reflex t

82+ , PrimMonad m

83+ , MonadFix m

84+ )

85+ => RequesterT t request response m a

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

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

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

89+ (_, tg) <- RequesterInternalT ask

90+ result <- a

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

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

93+ Just Refl -> Just m

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

95+

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

97+ lift = RequesterInternalT . lift . lift

98+

99+instance MonadTrans (RequesterT t request response) where

100+ lift a = RequesterT $ RequesterInternalT $ lift $ lift a

101+

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

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

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

105+-- requests were issued.

106+withRequesterInternalT

107+ :: ( Reflex t

108+ , PrimMonad m

109+ , MonadFix m

110+ )

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

112+ -> m a

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

114+ rec let RequesterInternalT a = f requests

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

116+ pure result

117+

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

119+

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

121+

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

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

124+

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

126+ pure x = RequesterT $ pure x

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

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

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

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

131+

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

133+ return = pure

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

135+ RequesterT y -> y

136+

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

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

139+ RequesterT a -> a

140+

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

142+ liftIO a = RequesterT $ liftIO a

143+

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

145+ throw e = RequesterT $ throw e

146+

147+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 }

148+ deriving

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

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

151+ , MonadAsyncException

152+#endif

153+ )

154+

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

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

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

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

159+-- #endif

160+

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

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

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

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

165+

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

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

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

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

170+

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

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

173+ primitive = lift . primitive

174+

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

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

177+ mempty = pure mempty

178+ mappend = liftA2 mappend

179+

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

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

182+

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

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

185+ performEvent_ = lift . performEvent_

186+ performEvent = lift . performEvent

187+

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

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

190+ newRef = lift . newRef

191+ readRef = lift . readRef

192+ writeRef r = lift . writeRef r

193+

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

195+ newEventWithTrigger = lift . newEventWithTrigger

196+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

197+

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

199+ ask = lift ask

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

201+ reader = lift . reader

202+

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

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

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

206+ requesting e = RequesterT $ requesting e

207+ requesting_ e = RequesterT $ requesting_ e

208+

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

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

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

212+ requesting e = RequesterInternalT $ do

213+ (s, tg) <- ask

214+ t <- lift $ lift $ newTag tg

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

216+ pure $ selectTag s t

217+ requesting_ e = RequesterInternalT $ do

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

219+

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

221+ {-# INLINABLE runWithReplace #-}

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

223+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

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

225+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

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

227+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

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

229+

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

231+ {-# INLINABLE runWithReplace #-}

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

233+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

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

235+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

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

237+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

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

239+

240+{-# INLINABLE runWithReplaceRequesterTWith #-}

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

242+ , MonadFix m

243+ )

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

245+ -> RequesterT t request response m a

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

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

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

249+ pure undefined

250+

251+{-

252+import GHC.Exts (Any)

253+import Unsafe.Coerce

254+

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

256+

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

258+

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

260+

261+data RequesterDataKey a where

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

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

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

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

266+

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

268+singletonRequesterData rdk v = case rdk of

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

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

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

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

273+

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

275+requesterDataToList (RequesterData m) = do

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

277+ case myKeyType k of

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

279+ MyTagType_Multi -> do

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

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

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

283+ MyTagType_Multi2 -> do

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

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

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

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

288+ MyTagType_Multi3 -> do

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

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

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

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

293+

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

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

296+

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

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

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

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

301+

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

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

304+ where

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

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

307+

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

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

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

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

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

313+ MyTagType_Single -> f request

314+ MyTagType_Multi -> traverse (traverseRequesterData f) request

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

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

317+

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

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

320+forRequesterData r f = traverseRequesterData f r

321+

322+data MyTagType :: * -> * where

323+ MyTagType_Single :: MyTagType (Single a)

324+ MyTagType_Multi :: MyTagType Multi

325+ MyTagType_Multi2 :: MyTagType (Multi2 k)

326+ MyTagType_Multi3 :: MyTagType Multi3

327+

328+myKeyType :: MyTag x -> MyTagType x

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

330+ 0x0 -> unsafeCoerce MyTagType_Single

331+ 0x1 -> unsafeCoerce MyTagType_Multi

332+ 0x2 -> unsafeCoerce MyTagType_Multi2

333+ 0x3 -> unsafeCoerce MyTagType_Multi3

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

335+

336+data Single a

337+data Multi

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

339+data Multi3

340+

341+class MyTagTypeOffset x where

342+ myTagTypeOffset :: proxy x -> Int

343+

344+instance MyTagTypeOffset (Single a) where

345+ myTagTypeOffset _ = 0x0

346+

347+instance MyTagTypeOffset Multi where

348+ myTagTypeOffset _ = 0x1

349+

350+instance MyTagTypeOffset (Multi2 k) where

351+ myTagTypeOffset _ = 0x2

352+

353+instance MyTagTypeOffset Multi3 where

354+ myTagTypeOffset _ = 0x3

355+

356+type family EntryContents request a where

357+ EntryContents request (Single a) = request a

358+ EntryContents request Multi = IntMap (RequesterData request)

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

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

361+

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

363+

364+{-# INLINE singleEntry #-}

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

366+singleEntry = Entry

367+

368+{-# INLINE multiEntry #-}

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

370+multiEntry = Entry

371+

372+{-# INLINE unMultiEntry #-}

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

374+unMultiEntry = unEntry

375+

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

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

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

379+

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

381+

382+{-# INLINE castMyTagWrap #-}

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

384+castMyTagWrap = coerce

385+

386+instance GEq MyTag where

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

388+ if a == b

389+ then Just $ unsafeCoerce Refl

390+ else Nothing

391+

392+instance GCompare MyTag where

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

394+ case a `compare` b of

395+ LT -> GLT

396+ EQ -> unsafeCoerce GEQ

397+ GT -> GGT

398+

399+instance GEq (MyTagWrap f) where

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

401+ if a == b

402+ then Just $ unsafeCoerce Refl

403+ else Nothing

404+

405+instance GCompare (MyTagWrap f) where

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

407+ case a `compare` b of

408+ LT -> GLT

409+ EQ -> unsafeCoerce GEQ

410+ GT -> GGT

411+

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

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

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

415+ }

416+

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

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

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

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

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

422+ , MonadAsyncException

423+#endif

424+ )

425+

426+

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

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

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

430+-- requests were issued.

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

432+ => RequesterT t request response m a

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

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

435+runRequesterT (RequesterT a) responses = do

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

437+ coerceEvent responses

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

439+

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

441+withRequesterT

442+ :: (Reflex t, MonadFix m)

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

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

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

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

447+withRequesterT freq frsp child = do

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

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

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

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

452+ return a

453+

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

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

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

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

458+ requesting_ = void . tagRequest . fmapCheap singleEntry

459+

460+{-# INLINE tagRequest #-}

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

462+tagRequest req = do

463+ old <- RequesterT get

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

465+ t = MyTagWrap n

466+ RequesterT $ put $ RequesterState

467+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

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

469+ }

470+ return t

471+

472+{-# INLINE responseFromTag #-}

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

474+responseFromTag (MyTagWrap t) = do

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

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

477+

478+instance MonadTrans (RequesterT t request response) where

479+ lift = RequesterT . lift . lift

480+

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

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

483+ performEvent_ = lift . performEvent_

484+ performEvent = lift . performEvent

485+

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

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

488+ newRef = lift . newRef

489+ readRef = lift . readRef

490+ writeRef r = lift . writeRef r

491+

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

493+ newEventWithTrigger = lift . newEventWithTrigger

494+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

495+

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

497+ ask = lift ask

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

499+ reader = lift . reader

500+

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

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

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

504+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

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

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

507+

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

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

510+

511+{-# INLINABLE runWithReplaceRequesterTWith #-}

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

513+ , MonadFix m

514+ )

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

516+ -> RequesterT t request response m a

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

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

519+runWithReplaceRequesterTWith f a0 a' = do

520+ rec na' <- numberOccurrencesFrom 1 a'

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

522+ let responses' = fanInt responses

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

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

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

526+

527+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

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

529+ ( Reflex t

530+ , MonadHold t m

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

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

533+ , Functor p

534+ , MonadFix m

535+ )

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

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

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

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

540+ )

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

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

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

544+ -> IntMap v

545+ -> Event t (p v)

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

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

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

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

550+ responses = fanInt $ fmapCheap unpack response

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

552+ unpack = unEntry

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

554+ pack = Entry

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

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

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

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

559+ ndm' <- numberOccurrencesFrom 1 dm'

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

561+ let result0 = fmap snd children0

562+ result' = fforCheap children' $ fmap snd

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

564+ requests0 = fmap fst children0

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

566+ requests' = fforCheap children' $ fmap fst

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

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

569+ requests <- holdIncremental requests0 requests'

570+ return (result0, result')

571+

572+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

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

574+ ( GCompare k

575+ , Reflex t

576+ , MonadHold t m

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

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

579+ , MonadFix m

580+ )

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

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

583+ -> DMap k' v1

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

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

586+ )

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

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

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

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

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

592+ -> DMap k v

593+ -> Event t (p k v)

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

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

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

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

598+ responses = fanMap $ fmapCheap unpack response

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

600+ unpack = unEntry

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

602+ pack = Entry

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

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

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

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

607+ ndm' <- numberOccurrencesFrom 1 dm'

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

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

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

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

612+ requests0 = weakenDMapWith (fst . getCompose) children0

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

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

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

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

617+ requests <- holdIncremental requests0 requests'

618+ return (result0, result')

619+

620+data Decoder rawResponse response =

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

622+

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

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

625+-- incoming responses.

626+matchResponsesWithRequests

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

628+ ( MonadFix m

629+ , MonadHold t m

630+ , Reflex t

631+ )

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

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

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

635+ -> Event t (RequesterData request)

636+ -- ^ The outgoing requests

637+ -> Event t (Int, rawResponse)

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

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

640+ , Event t (RequesterData response)

641+ )

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

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

644+matchResponsesWithRequests f send recv = do

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

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

647+ holdIncremental mempty $ leftmost

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

649+ , snd <$> incoming

650+ ]

651+ let outgoing = processOutgoing nextId send

652+ incoming = processIncoming waitingFor recv

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

654+ where

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

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

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

658+ -- raw requests to be sent out.

659+ processOutgoing

660+ :: Behavior t Int

661+ -- The next available key

662+ -> Event t (RequesterData request)

663+ -- The outgoing request

664+ -> Event t ( Int

665+ , PatchMap Int (Decoder rawResponse response)

666+ , Map Int rawRequest )

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

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

669+ oldNextId <- sample nextId

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

671+ n <- get

672+ put $ succ n

673+ let (rawReq, rspF) = f v

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

675+ patchWaitingFor = PatchMap $ Map.fromList $

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

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

678+ return (newNextId, patchWaitingFor, toSend)

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

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

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

682+ -- of expected responses.

683+ processIncoming

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

685+ -- A map of outstanding expected responses

686+ -> Event t (Int, rawResponse)

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

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

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

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

691+ wf <- sample $ currentIncremental waitingFor

692+ case Map.lookup n wf of

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

694+ Just (Decoder k rspF) -> do

695+ let rsp = rspF rawRsp

696+ return $ Just

697+ ( singletonRequesterData k rsp

698+ , PatchMap $ Map.singleton n Nothing

699+ )

700+-}

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