develop...de53a95 · reflex

git.iko.soy/reflex

on de53a95 help sign in

default.nixdeleted−43

since splitsnapshots

unifiedsplit

@@ -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+12−4

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

57 containers >= 0.6 && < 0.7,

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

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

60+ dlist == 0.8.*,

60 exception-transformers == 0.4.*,

61 exception-transformers == 0.4.*,

61 profunctors >= 5.3 && < 5.5,

62 profunctors >= 5.3 && < 5.5,

62 lens >= 4.7 && < 5,

63 lens >= 4.7 && < 5,

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

90 Data.FastMutableIntMap,

91 Data.FastMutableIntMap,

91 Data.FastWeakBag,

92 Data.FastWeakBag,

92 Data.Functor.Misc,

93 Data.Functor.Misc,

94+ Data.List.NonEmpty.Deferred,

93 Data.Map.Misc,

95 Data.Map.Misc,

96+ Data.TagMap,

97+ Data.Unique.Tag.Local,

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

94 Data.WeakBag,

99 Data.WeakBag,

95 Reflex,

100 Reflex,

96− Reflex.Class,

97 Reflex.Adjustable.Class,

101 Reflex.Adjustable.Class,

98 Reflex.BehaviorWriter.Base,

102 Reflex.BehaviorWriter.Base,

99 Reflex.BehaviorWriter.Class,

103 Reflex.BehaviorWriter.Class,

104+ Reflex.Class,

100 Reflex.Collection,

105 Reflex.Collection,

101 Reflex.Dynamic,

106 Reflex.Dynamic,

102 Reflex.Dynamic.Uniq,

107 Reflex.Dynamic.Uniq,

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

106 Reflex.EventWriter,

111 Reflex.EventWriter,

107 Reflex.EventWriter.Base,

112 Reflex.EventWriter.Base,

108 Reflex.EventWriter.Class,

113 Reflex.EventWriter.Class,

114+ Reflex.FanTag,

109 Reflex.FastWeak,

115 Reflex.FastWeak,

110 Reflex.FunctorMaybe,

116 Reflex.FunctorMaybe,

111 Reflex.Host.Class,

117 Reflex.Host.Class,

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

127 Reflex.Query.Base,

133 Reflex.Query.Base,

128 Reflex.Query.Class,

134 Reflex.Query.Class,

129 Reflex.Requester.Base,

135 Reflex.Requester.Base,

136+ Reflex.Requester.Base.Internal,

130 Reflex.Requester.Class,

137 Reflex.Requester.Class,

131 Reflex.Spider,

138 Reflex.Spider,

132 Reflex.Spider.Internal,

139 Reflex.Spider.Internal,

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

259 build-depends: base

266 build-depends: base

260 , containers

267 , containers

261 , deepseq

268 , deepseq

262− , dependent-sum

263 , dependent-map

269 , dependent-map

270+ , dependent-sum

264 , lens

271 , lens

265 , mtl

272 , mtl

273+ , primitive

274+ , ref-tf

275+ , reflex

266 , these

276 , these

267 , transformers

277 , transformers

268− , reflex

269− , ref-tf

270

278

271 if flag(split-these)

279 if flag(split-these)

272 build-depends: these-lens

280 build-depends: these-lens

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/Dynamic.hs+1

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

191 let eLag = switch $ current de

192 eCoincidences = coincidence $ updated de

193 in leftmost [eCoincidences, eLag]

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

194

195

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

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

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

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

src/Reflex/EventWriter/Base.hs+3

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

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

201 return (result0, result')

202

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

204+switchHoldPromptOnlyIntMapIncremental = switchHoldPromptOnlyIncremental mergeIntIncremental coincidencePatchIntMap

205+

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

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

204sequenceDMapWithAdjustEventWriterTWith

207sequenceDMapWithAdjustEventWriterTWith

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

208 :: 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 (..))

25import Reflex.PostBuild.Base (PostBuildT)

26import Reflex.Query.Base (QueryT)

27import Reflex.Requester.Base (RequesterT)

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

28import Reflex.TriggerEvent.Base (TriggerEventT)

29import Reflex.TriggerEvent.Base (TriggerEventT)

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

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

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

72 notReadyUntil = lift . notReadyUntil

73 notReadyUntil = lift . notReadyUntil

73 notReady = lift notReady

74 notReady = lift notReady

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

77+ notReadyUntil = lift . notReadyUntil

78+ notReady = lift notReady

79+

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

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

76 notReadyUntil = lift . notReadyUntil

81 notReadyUntil = lift . notReadyUntil

77 notReady = lift notReady

82 notReady = lift notReady

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

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

1{-# LANGUAGE DeriveFoldable #-}

2{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE DeriveTraversable #-}

4+{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE TemplateHaskell #-}

5{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

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

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

7-- insert/update or delete of associations.

10-- insert/update or delete of associations.

8module Reflex.Patch.IntMap where

11module Reflex.Patch.IntMap where

13+import Control.Lens

10import Data.IntMap.Strict (IntMap)

14import Data.IntMap.Strict (IntMap)

11import qualified Data.IntMap.Strict as IntMap

15import qualified Data.IntMap.Strict as IntMap

12import Data.Maybe

16import Data.Maybe

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

18-- and @Nothing@ means delete.

22-- and @Nothing@ means delete.

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

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

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−

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

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

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

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

31-- precedence.

27-- precedence.

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

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

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

35 stimes = stimesIdempotentMonoid

31 stimes = stimesIdempotentMonoid

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+

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

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

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

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

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

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

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

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

48+instance FunctorWithIndex Int PatchIntMap

49+instance FoldableWithIndex Int PatchIntMap

50+instance TraversableWithIndex Int PatchIntMap where

51+ itraversed = _Wrapped . itraversed . traversed

52+

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

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

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

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

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

55traverseIntMapPatchWithKey :: 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

28import Reflex.Adjustable.Class

29import Reflex.Host.Class

30import Reflex.PerformEvent.Class

31−import Reflex.Requester.Base

31+import Reflex.Requester.Base.Internal

32import Reflex.Requester.Class

33+import Reflex.EventWriter.Class

34+import Reflex.EventWriter.Base

34import Control.Lens

36import Control.Lens

35import Control.Monad.Exception

37import Control.Monad.Exception

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

37import Control.Monad.Primitive

39import Control.Monad.Primitive

38import Control.Monad.Reader

40import Control.Monad.Reader

39import Control.Monad.Ref

41import Control.Monad.Ref

40−import Data.Coerce

41import Data.Dependent.Map (DMap)

42import Data.Dependent.Map (DMap)

42import qualified Data.Dependent.Map as DMap

43import qualified Data.Dependent.Map as DMap

43import Data.Dependent.Sum

44import Data.Dependent.Sum

45+import Data.Foldable

46+import Data.Functor.Compose

47+import Data.Functor.Misc

44import Data.IntMap.Strict (IntMap)

48import Data.IntMap.Strict (IntMap)

45import qualified Data.IntMap.Strict as IntMap

49import 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))

46import qualified Data.Semigroup as S

56import 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

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

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

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

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

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

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

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

69 primitive = PerformEventT . lift . primitive

83 primitive = PerformEventT . lift . primitive

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

72 type Performable (PerformEventT t m) = HostFrame t

86 type Performable (PerformEventT t m) = HostFrame t

73 {-# INLINABLE performEvent_ #-}

87 {-# INLINABLE performEvent_ #-}

74 performEvent_ = PerformEventT . requesting_

88 performEvent_ = PerformEventT . requesting_

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

76 performEvent = PerformEventT . requestingIdentity

90 performEvent = PerformEventT . requestingIdentity

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

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

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

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

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

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

81− f a0 a' = do

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

82− result0 <- lift a0

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

83− result' <- requestingIdentity a'

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

84− return (result0, result')

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

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

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

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

101+ RequesterInternalT $ tellEvent requests

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

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

157

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

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

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

159 => ((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.

124 , MonadReflexHost t m

193 , MonadReflexHost t m

125 , MonadRef m

194 , MonadRef m

126 , Ref m ~ Ref IO

195 , Ref m ~ Ref IO

196+ , PrimMonad (HostFrame t)

127 )

197 )

128 => PerformEventT t m a

198 => PerformEventT t m a

129 -> m (a, FireCommand t m)

199 -> m (a, FireCommand t m)

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

142 Nothing -> return [result']

212 Nothing -> return [result']

143 Just toPerform -> do

213 Just toPerform -> do

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

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

215+ let responseLength = case responses of

216+ ResponseData _ m -> TagMap.size m

145 mrt <- readRef responseTrigger

217 mrt <- readRef responseTrigger

146 let followupEventTriggers = case mrt of

218 let followupEventTriggers = case mrt of

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

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

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

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

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

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

21module Reflex.Requester.Base

3module Reflex.Requester.Base

22 ( RequesterT (..)

4 ( RequesterT (..)

5+ , RequestData (..)

6+ , ResponseData (..)

7+ , RequestEnvelope (..)

23 , runRequesterT

8 , runRequesterT

24− , withRequesterT

9+-- , withRequesterT

25− , runWithReplaceRequesterTWith

26− , traverseIntMapWithKeyWithAdjustRequesterTWith

27− , traverseDMapWithKeyWithAdjustRequesterTWith

28− , RequesterData

10+-- , RequesterData

29− , RequesterDataKey

11+-- , RequesterDataKey

30 , traverseRequesterData

12 , traverseRequesterData

31− , forRequesterData

13+-- , forRequesterData

32− , requesterDataToList

14+-- , requesterDataToList

33− , singletonRequesterData

15+-- , singletonRequesterData

34− , matchResponsesWithRequests

16+-- , matchResponsesWithRequests

35− , multiEntry

17+-- , multiEntry

36− , unMultiEntry

18+-- , unMultiEntry

37− , requesting'

19+-- , requesting'

38 ) where

20 ) where

40−import Reflex.Class

22+import Reflex.Requester.Base.Internal

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

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

@@ -0,0 +1,706 @@

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+--TODO: The use of Seq in this module could probably be replaced with something

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

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

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

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

76+

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

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

79+

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

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

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

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

84+ Nothing -> Nothing <$ f req

85+

86+runRequesterT :: forall t request response m a

87+ . ( Reflex t

88+ , PrimMonad m

89+ , MonadFix m

90+ )

91+ => RequesterT t request response m a

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

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

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

95+ (_, tg) <- RequesterInternalT ask

96+ result <- a

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

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

99+ Just Refl -> Just m

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

101+

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

103+ lift = RequesterInternalT . lift . lift

104+

105+instance MonadTrans (RequesterT t request response) where

106+ lift a = RequesterT $ RequesterInternalT $ lift $ lift a

107+

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

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

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

111+-- requests were issued.

112+withRequesterInternalT

113+ :: ( Reflex t

114+ , PrimMonad m

115+ , MonadFix m

116+ )

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

118+ -> m a

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

120+ rec let RequesterInternalT a = f requests

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

122+ pure result

123+

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

125+

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

127+

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

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

130+

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

132+ pure x = RequesterT $ pure x

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

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

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

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

137+

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

139+ return = pure

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

141+ RequesterT y -> y

142+

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

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

145+ RequesterT a -> a

146+

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

148+ liftIO a = RequesterT $ liftIO a

149+

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

151+ throw e = RequesterT $ throw e

152+

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

154+ deriving

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

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

157+ , MonadAsyncException

158+#endif

159+ )

160+

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

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

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

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

165+-- #endif

166+

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

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

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

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

171+

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

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

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

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

176+

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

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

179+ primitive = lift . primitive

180+

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

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

183+ mempty = pure mempty

184+ mappend = liftA2 mappend

185+

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

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

188+

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

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

191+ performEvent_ = lift . performEvent_

192+ performEvent = lift . performEvent

193+

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

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

196+ newRef = lift . newRef

197+ readRef = lift . readRef

198+ writeRef r = lift . writeRef r

199+

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

201+ newEventWithTrigger = lift . newEventWithTrigger

202+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

203+

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

205+ ask = lift ask

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

207+ reader = lift . reader

208+

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

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

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

212+ requesting e = RequesterT $ requesting e

213+ requesting_ e = RequesterT $ requesting_ e

214+

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

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

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

218+ requesting e = RequesterInternalT $ do

219+ (s, tg) <- ask

220+ t <- lift $ lift $ newTag tg

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

222+ pure $ selectTag s t

223+ requesting_ e = RequesterInternalT $ do

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

225+

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

227+ {-# INLINABLE runWithReplace #-}

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

229+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

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

231+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

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

233+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

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

235+

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

237+ {-# INLINABLE runWithReplace #-}

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

239+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

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

241+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

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

243+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

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

245+

246+{-# INLINABLE runWithReplaceRequesterTWith #-}

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

248+ , MonadFix m

249+ )

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

251+ -> RequesterT t request response m a

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

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

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

255+ pure undefined

256+

257+{-

258+import GHC.Exts (Any)

259+import Unsafe.Coerce

260+

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

262+

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

264+

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

266+

267+data RequesterDataKey a where

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

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

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

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

272+

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

274+singletonRequesterData rdk v = case rdk of

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

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

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

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

279+

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

281+requesterDataToList (RequesterData m) = do

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

283+ case myKeyType k of

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

285+ MyTagType_Multi -> do

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

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

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

289+ MyTagType_Multi2 -> do

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

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

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

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

294+ MyTagType_Multi3 -> do

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

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

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

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

299+

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

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

302+

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

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

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

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

307+

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

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

310+ where

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

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

313+

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

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

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

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

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

319+ MyTagType_Single -> f request

320+ MyTagType_Multi -> traverse (traverseRequesterData f) request

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

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

323+

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

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

326+forRequesterData r f = traverseRequesterData f r

327+

328+data MyTagType :: * -> * where

329+ MyTagType_Single :: MyTagType (Single a)

330+ MyTagType_Multi :: MyTagType Multi

331+ MyTagType_Multi2 :: MyTagType (Multi2 k)

332+ MyTagType_Multi3 :: MyTagType Multi3

333+

334+myKeyType :: MyTag x -> MyTagType x

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

336+ 0x0 -> unsafeCoerce MyTagType_Single

337+ 0x1 -> unsafeCoerce MyTagType_Multi

338+ 0x2 -> unsafeCoerce MyTagType_Multi2

339+ 0x3 -> unsafeCoerce MyTagType_Multi3

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

341+

342+data Single a

343+data Multi

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

345+data Multi3

346+

347+class MyTagTypeOffset x where

348+ myTagTypeOffset :: proxy x -> Int

349+

350+instance MyTagTypeOffset (Single a) where

351+ myTagTypeOffset _ = 0x0

352+

353+instance MyTagTypeOffset Multi where

354+ myTagTypeOffset _ = 0x1

355+

356+instance MyTagTypeOffset (Multi2 k) where

357+ myTagTypeOffset _ = 0x2

358+

359+instance MyTagTypeOffset Multi3 where

360+ myTagTypeOffset _ = 0x3

361+

362+type family EntryContents request a where

363+ EntryContents request (Single a) = request a

364+ EntryContents request Multi = IntMap (RequesterData request)

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

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

367+

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

369+

370+{-# INLINE singleEntry #-}

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

372+singleEntry = Entry

373+

374+{-# INLINE multiEntry #-}

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

376+multiEntry = Entry

377+

378+{-# INLINE unMultiEntry #-}

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

380+unMultiEntry = unEntry

381+

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

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

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

385+

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

387+

388+{-# INLINE castMyTagWrap #-}

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

390+castMyTagWrap = coerce

391+

392+instance GEq MyTag where

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

394+ if a == b

395+ then Just $ unsafeCoerce Refl

396+ else Nothing

397+

398+instance GCompare MyTag where

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

400+ case a `compare` b of

401+ LT -> GLT

402+ EQ -> unsafeCoerce GEQ

403+ GT -> GGT

404+

405+instance GEq (MyTagWrap f) where

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

407+ if a == b

408+ then Just $ unsafeCoerce Refl

409+ else Nothing

410+

411+instance GCompare (MyTagWrap f) where

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

413+ case a `compare` b of

414+ LT -> GLT

415+ EQ -> unsafeCoerce GEQ

416+ GT -> GGT

417+

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

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

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

421+ }

422+

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

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

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

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

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

428+ , MonadAsyncException

429+#endif

430+ )

431+

432+

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

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

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

436+-- requests were issued.

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

438+ => RequesterT t request response m a

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

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

441+runRequesterT (RequesterT a) responses = do

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

443+ coerceEvent responses

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

445+

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

447+withRequesterT

448+ :: (Reflex t, MonadFix m)

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

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

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

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

453+withRequesterT freq frsp child = do

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

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

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

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

458+ return a

459+

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

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

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

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

464+ requesting_ = void . tagRequest . fmapCheap singleEntry

465+

466+{-# INLINE tagRequest #-}

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

468+tagRequest req = do

469+ old <- RequesterT get

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

471+ t = MyTagWrap n

472+ RequesterT $ put $ RequesterState

473+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

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

475+ }

476+ return t

477+

478+{-# INLINE responseFromTag #-}

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

480+responseFromTag (MyTagWrap t) = do

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

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

483+

484+instance MonadTrans (RequesterT t request response) where

485+ lift = RequesterT . lift . lift

486+

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

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

489+ performEvent_ = lift . performEvent_

490+ performEvent = lift . performEvent

491+

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

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

494+ newRef = lift . newRef

495+ readRef = lift . readRef

496+ writeRef r = lift . writeRef r

497+

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

499+ newEventWithTrigger = lift . newEventWithTrigger

500+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

501+

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

503+ ask = lift ask

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

505+ reader = lift . reader

506+

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

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

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

510+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

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

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

513+

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

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

516+

517+{-# INLINABLE runWithReplaceRequesterTWith #-}

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

519+ , MonadFix m

520+ )

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

522+ -> RequesterT t request response m a

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

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

525+runWithReplaceRequesterTWith f a0 a' = do

526+ rec na' <- numberOccurrencesFrom 1 a'

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

528+ let responses' = fanInt responses

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

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

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

532+

533+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

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

535+ ( Reflex t

536+ , MonadHold t m

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

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

539+ , Functor p

540+ , MonadFix m

541+ )

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

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

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

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

546+ )

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

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

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

550+ -> IntMap v

551+ -> Event t (p v)

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

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

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

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

556+ responses = fanInt $ fmapCheap unpack response

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

558+ unpack = unEntry

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

560+ pack = Entry

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

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

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

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

565+ ndm' <- numberOccurrencesFrom 1 dm'

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

567+ let result0 = fmap snd children0

568+ result' = fforCheap children' $ fmap snd

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

570+ requests0 = fmap fst children0

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

572+ requests' = fforCheap children' $ fmap fst

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

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

575+ requests <- holdIncremental requests0 requests'

576+ return (result0, result')

577+

578+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

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

580+ ( GCompare k

581+ , Reflex t

582+ , MonadHold t m

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

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

585+ , MonadFix m

586+ )

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

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

589+ -> DMap k' v1

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

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

592+ )

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

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

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

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

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

598+ -> DMap k v

599+ -> Event t (p k v)

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

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

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

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

604+ responses = fanMap $ fmapCheap unpack response

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

606+ unpack = unEntry

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

608+ pack = Entry

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

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

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

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

613+ ndm' <- numberOccurrencesFrom 1 dm'

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

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

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

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

618+ requests0 = weakenDMapWith (fst . getCompose) children0

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

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

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

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

623+ requests <- holdIncremental requests0 requests'

624+ return (result0, result')

625+

626+data Decoder rawResponse response =

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

628+

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

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

631+-- incoming responses.

632+matchResponsesWithRequests

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

634+ ( MonadFix m

635+ , MonadHold t m

636+ , Reflex t

637+ )

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

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

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

641+ -> Event t (RequesterData request)

642+ -- ^ The outgoing requests

643+ -> Event t (Int, rawResponse)

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

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

646+ , Event t (RequesterData response)

647+ )

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

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

650+matchResponsesWithRequests f send recv = do

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

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

653+ holdIncremental mempty $ leftmost

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

655+ , snd <$> incoming

656+ ]

657+ let outgoing = processOutgoing nextId send

658+ incoming = processIncoming waitingFor recv

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

660+ where

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

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

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

664+ -- raw requests to be sent out.

665+ processOutgoing

666+ :: Behavior t Int

667+ -- The next available key

668+ -> Event t (RequesterData request)

669+ -- The outgoing request

670+ -> Event t ( Int

671+ , PatchMap Int (Decoder rawResponse response)

672+ , Map Int rawRequest )

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

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

675+ oldNextId <- sample nextId

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

677+ n <- get

678+ put $ succ n

679+ let (rawReq, rspF) = f v

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

681+ patchWaitingFor = PatchMap $ Map.fromList $

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

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

684+ return (newNextId, patchWaitingFor, toSend)

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

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

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

688+ -- of expected responses.

689+ processIncoming

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

691+ -- A map of outstanding expected responses

692+ -> Event t (Int, rawResponse)

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

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

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

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

697+ wf <- sample $ currentIncremental waitingFor

698+ case Map.lookup n wf of

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

700+ Just (Decoder k rspF) -> do

701+ let rsp = rspF rawRsp

702+ return $ Just

703+ ( singletonRequesterData k rsp

704+ , PatchMap $ Map.singleton n Nothing

705+ )

706+-}

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

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

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

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

42 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

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

46 type Request (ReaderT r m) = Request m

test/EventWriterT.hs+15−11

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

25main :: IO ()

26main = do

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

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

28 [ Just ()

29 ]

30 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 $

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

33− [ This ()

32+ [ This ()

34− , That ()

33+ , That ()

35− , This ()

34+ , This ()

36− , These () ()

35+ , These () ()

37− ]

36+ ]

38 print os2

37 print os2

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

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

40 print os3

39 print os3

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

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

42 print os4

41 print os4

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

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

44 print os5

43 print os5

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

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

46 print os6

45 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

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

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

48 return ()

52 return ()

test/RequesterT.hs+31−26

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

10import Control.Lens

11import Control.Monad

12import Control.Monad.Fix

13+import Control.Monad.Primitive

13import qualified Data.Dependent.Map as DMap

14import qualified Data.Dependent.Map as DMap

14import Data.Dependent.Sum

15import Data.Dependent.Sum

15import Data.Functor.Misc

16import Data.Functor.Misc

16import qualified Data.Map as M

17import qualified Data.Map as M

17import Data.These

18import Data.These

19+import Data.Foldable

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

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

20import Data.These.Lens

22import Data.These.Lens

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

31main :: IO ()

33main :: IO ()

32main = do

34main = do

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

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

34− [ Just ()

36+-- [ Just ()

35− ]

37+-- ]

36− print os1

38+-- print os1

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

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

38− [ This ()

40+-- [ This ()

39− , That ()

41+-- , That ()

40− , This ()

42+-- , This ()

41− , These () ()

43+-- , These () ()

42− ]

44+-- ]

43− print os2

45+-- print os2

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

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

45− print os3

47+-- print os3

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

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

47 print os4

49 print os4

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

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

49− print os5

51+-- print os5

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

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

51− print os6

53+-- 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'

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

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

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

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

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

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

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

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

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

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

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

58 return ()

60 return ()

60−unwrapRequest :: DSum tag RequestInt -> Int

62+unwrapApp :: forall t m a.

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

62−

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

63+ ( Reflex t

64+ , MonadFix m

65+ , PrimMonad m

66+ )

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

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

65 -> a

68 -> a

66 -> m (Event t [Int])

69 -> m (Event t [Int])

67unwrapApp x appIn = do

70unwrapApp x appIn = do

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

71 ((), 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

71testOrdering :: ( Response m ~ Identity

76testOrdering :: ( Response m ~ Identity

72 , Request m ~ RequestInt

77 , Request m ~ RequestInt