86ab4e2...develop · reflex

git.iko.soy/reflex

ChangeLog.md+4

since splitsnapshots

@@ -1,5 +1,9 @@

1# Revision history for reflex

3+## 0.8.2.0

5+* Add `matchResponseMapWithRequests`, which it similar to `matchResponsesWithRequests` but allows processing of multiple responses at once.

3## 0.8.1.1

7## 0.8.1.1

5* Allow newer hlint for older GHCs, and add upper bound for newer GHCs

9* Allow newer hlint for older GHCs, and add upper bound for newer GHCs

reflex.cabal+3−2

@@ -1,5 +1,5 @@

1Name: reflex

2−Version: 0.8.1.1

2+Version: 0.8.2.0

3Synopsis: Higher-order Functional Reactive Programming

4Description:

5 Interactive programs without callbacks or side-effects.

@@ -74,6 +74,7 @@ library

74 base >= 4.11 && < 4.15,

75 bifunctors >= 5.2 && < 5.6,

76 comonad >= 5.0.4 && < 5.1,

77+ constraints >= 0.10 && <0.14,

77 constraints-extras >= 0.3 && < 0.4,

78 constraints-extras >= 0.3 && < 0.4,

78 containers >= 0.6 && < 0.7,

79 containers >= 0.6 && < 0.7,

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

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

@@ -96,7 +97,7 @@ library

96 time >= 1.4 && < 1.10,

97 time >= 1.4 && < 1.10,

97 transformers >= 0.5.6.0 && < 0.6,

98 transformers >= 0.5.6.0 && < 0.6,

98 unbounded-delays >= 0.1.0.0 && < 0.2,

99 unbounded-delays >= 0.1.0.0 && < 0.2,

99− witherable >= 0.3 && < 0.4

100+ witherable >= 0.3 && < 0.5

100

101

101 if flag(split-these)

102 if flag(split-these)

102 build-depends: these >= 1 && <1.2,

103 build-depends: these >= 1 && <1.2,

src/Reflex/Requester/Base.hs+91−26

@@ -1,6 +1,7 @@

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

2-- 'Requester'.

3{-# LANGUAGE AllowAmbiguousTypes #-}

4+{-# LANGUAGE ApplicativeDo #-}

4{-# LANGUAGE CPP #-}

5{-# LANGUAGE CPP #-}

5{-# LANGUAGE EmptyDataDecls #-}

6{-# LANGUAGE EmptyDataDecls #-}

6{-# LANGUAGE ExistentialQuantification #-}

7{-# LANGUAGE ExistentialQuantification #-}

@@ -32,6 +33,7 @@ module Reflex.Requester.Base

32 , requesterDataToList

33 , requesterDataToList

33 , singletonRequesterData

34 , singletonRequesterData

34 , matchResponsesWithRequests

35 , matchResponsesWithRequests

36+ , matchResponseMapWithRequests

35 , multiEntry

37 , multiEntry

36 , unMultiEntry

38 , unMultiEntry

37 , requesting'

39 , requesting'

@@ -56,6 +58,7 @@ import Control.Monad.Ref

56import Control.Monad.State.Strict

58import Control.Monad.State.Strict

57import Data.Bits

59import Data.Bits

58import Data.Coerce

60import Data.Coerce

61+import Data.Constraint

59import Data.Dependent.Map (DMap)

62import Data.Dependent.Map (DMap)

60import qualified Data.Dependent.Map as DMap

63import qualified Data.Dependent.Map as DMap

61import Data.Dependent.Sum (DSum (..))

64import Data.Dependent.Sum (DSum (..))

@@ -81,19 +84,51 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

82newtype RequesterData f = RequesterData (TagMap (Entry f))

85newtype RequesterData f = RequesterData (TagMap (Entry f))

87+emptyRequesterData :: RequesterData f

88+emptyRequesterData = RequesterData $ TagMap IntMap.empty

89+

84data RequesterDataKey a where

90data RequesterDataKey a where

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

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

86 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

92 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

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

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

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

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

90singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

96singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

91singletonRequesterData rdk v = case rdk of

97singletonRequesterData rdk v = case rdk of

92 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

98 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

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

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

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

100+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Multi2Contents

101+ { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

102+ , _multi2Contents_dict = Dict

103+ }

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

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

105

106+mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f

107+mergeRequesterData (RequesterData a) (RequesterData b) = RequesterData $ mergeTagMap a b

108+

109+mergeTagMap :: forall f. TagMap (Entry f) -> TagMap (Entry f) -> TagMap (Entry f)

110+mergeTagMap (TagMap m) (TagMap n) =

111+ TagMap $ IntMap.unionWithKey (g' combiner) m n

112+ where

113+ combiner :: forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a

114+ combiner k (Entry a) (Entry b) = Entry $ case myKeyType k of

115+ MyTagType_Single -> a

116+ MyTagType_Multi -> IntMap.unionWith mergeRequesterData a b

117+ MyTagType_Multi2 -> case _multi2Contents_dict a of

118+ Dict -> Multi2Contents

119+ { _multi2Contents_values = Map.unionWith (IntMap.unionWith mergeRequesterData) (_multi2Contents_values a) (_multi2Contents_values b)

120+ , _multi2Contents_dict = Dict

121+ }

122+ MyTagType_Multi3 -> IntMap.unionWith (IntMap.unionWith mergeRequesterData) a b

123+ g' :: (forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a) -> Int -> Any -> Any -> Any

124+ g' f rawKey a b =

125+ let k = MyTag rawKey :: MyTag a

126+ fromAny :: Any -> Entry f a

127+ fromAny = unsafeCoerce

128+ toAny :: Entry f a -> Any

129+ toAny = unsafeCoerce

130+ in toAny $ f k (fromAny a) (fromAny b)

131+

97requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

132requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

98requesterDataToList (RequesterData m) = do

133requesterDataToList (RequesterData m) = do

99 k :=> Entry e <- tagMapToList m

134 k :=> Entry e <- tagMapToList m

@@ -103,11 +138,12 @@ requesterDataToList (RequesterData m) = do

103 (k', e') <- IntMap.toList e

138 (k', e') <- IntMap.toList e

104 k'' :=> e'' <- requesterDataToList e'

139 k'' :=> e'' <- requesterDataToList e'

105 return $ RequesterDataKey_Multi k k' k'' :=> e''

140 return $ RequesterDataKey_Multi k k' k'' :=> e''

106− MyTagType_Multi2 -> do

141+ MyTagType_Multi2 -> case _multi2Contents_dict e of

142+ Dict -> do

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

143+ (k', e') <- Map.toList $ _multi2Contents_values e

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

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

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

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

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

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

111 MyTagType_Multi3 -> do

147 MyTagType_Multi3 -> do

112 (k', e') <- IntMap.toList e

148 (k', e') <- IntMap.toList e

113 (k'', e'') <- IntMap.toList e'

149 (k'', e'') <- IntMap.toList e'

@@ -135,7 +171,13 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith

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

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

136 MyTagType_Single -> f request

172 MyTagType_Single -> f request

137 MyTagType_Multi -> traverse (traverseRequesterData f) request

173 MyTagType_Multi -> traverse (traverseRequesterData f) request

174+ MyTagType_Multi2 -> case request of

175+ Multi2Contents { _multi2Contents_values = request', _multi2Contents_dict = Dict } -> do

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

176+ v <- traverse (traverse (traverseRequesterData f)) request'

177+ pure $ Multi2Contents

178+ { _multi2Contents_values = v

179+ , _multi2Contents_dict = Dict

180+ }

139 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

181 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

140

182

141-- | 'traverseRequesterData' with its arguments flipped

183-- | 'traverseRequesterData' with its arguments flipped

@@ -179,9 +221,14 @@ instance MyTagTypeOffset Multi3 where

179type family EntryContents request a where

221type family EntryContents request a where

180 EntryContents request (Single a) = request a

222 EntryContents request (Single a) = request a

181 EntryContents request Multi = IntMap (RequesterData request)

223 EntryContents request Multi = IntMap (RequesterData request)

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

224+ EntryContents request (Multi2 k) = Multi2Contents k request

183 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

225 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

184

226

227+data Multi2Contents k request = Multi2Contents

228+ { _multi2Contents_dict :: {-# UNPACK #-} !(Dict (GCompare k)) -- This is a Dict instead of an existential context because we only want to use it in certain circumstances

229+ , _multi2Contents_values :: {-# UNPACK #-} !(Map (Some k) (IntMap (RequesterData request)))

230+ }

231+

185newtype Entry request x = Entry { unEntry :: EntryContents request x }

232newtype Entry request x = Entry { unEntry :: EntryContents request x }

186

233

187{-# INLINE singleEntry #-}

234{-# INLINE singleEntry #-}

@@ -310,7 +357,7 @@ tagRequest req = do

310 return t

357 return t

311

358

312{-# INLINE responseFromTag #-}

359{-# INLINE responseFromTag #-}

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

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

314responseFromTag (MyTagWrap t) = do

361responseFromTag (MyTagWrap t) = do

315 responses :: EventSelectorInt t Any <- RequesterT ask

362 responses :: EventSelectorInt t Any <- RequesterT ask

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

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

@@ -440,9 +487,9 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

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

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

441 responses = fanMap $ fmapCheap unpack response

488 responses = fanMap $ fmapCheap unpack response

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

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

443− unpack = unEntry

490+ unpack = _multi2Contents_values . unEntry

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

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

445− pack = Entry

492+ pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }

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

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

447 f' k (Compose (n, v)) = do

494 f' k (Compose (n, v)) = do

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

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

@@ -463,9 +510,6 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

463data Decoder rawResponse response =

510data Decoder rawResponse response =

464 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

511 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

465

512

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

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

468−-- incoming responses.

469matchResponsesWithRequests

513matchResponsesWithRequests

470 :: forall t rawRequest rawResponse request response m.

514 :: forall t rawRequest rawResponse request response m.

471 ( MonadFix m

515 ( MonadFix m

@@ -484,7 +528,30 @@ matchResponsesWithRequests

484 )

528 )

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

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

486 -- by the 'RequesterData' key of the associated outgoing request

530 -- by the 'RequesterData' key of the associated outgoing request

487−matchResponsesWithRequests f send recv = do

531+matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv

532+

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

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

535+-- incoming responses.

536+matchResponseMapWithRequests

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

538+ ( MonadFix m

539+ , MonadHold t m

540+ , Reflex t

541+ )

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

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

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

545+ -> Event t (RequesterData request)

546+ -- ^ The outgoing requests

547+ -> Event t (Map Int rawResponse)

548+ -- ^ A map of incoming responses, tagged by an identifying key

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

550+ , Event t (RequesterData response)

551+ )

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

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

554+matchResponseMapWithRequests f send recv = do

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

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

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

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

490 holdIncremental mempty $ leftmost

557 holdIncremental mempty $ leftmost

@@ -526,17 +593,15 @@ matchResponsesWithRequests f send recv = do

526 processIncoming

593 processIncoming

527 :: Incremental t (PatchMap Int (Decoder rawResponse response))

594 :: Incremental t (PatchMap Int (Decoder rawResponse response))

528 -- A map of outstanding expected responses

595 -- A map of outstanding expected responses

529− -> Event t (Int, rawResponse)

596+ -> Event t (Map Int rawResponse)

530 -- A incoming response paired with its identifying key

597 -- A incoming response paired with its identifying key

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

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

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

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

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

600+ processIncoming waitingFor inc = flip push inc $ \rspMap -> do

534 wf <- sample $ currentIncremental waitingFor

601 wf <- sample $ currentIncremental waitingFor

535− case Map.lookup n wf of

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

537− Just (Decoder k rspF) -> do

602+ let match rawRsp (Decoder k rspF) =

538− let rsp = rspF rawRsp

603+ let rsp = rspF rawRsp

539− return $ Just

540− ( singletonRequesterData k rsp

604+ in singletonRequesterData k rsp

541− , PatchMap $ Map.singleton n Nothing

605+ matches = Map.intersectionWith match rspMap wf

542− )

606+ pure $ if Map.null matches then Nothing else Just

607+ (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)