reflex 0.8.1.1 → 0.8.2.0

raw patch · 3 files changed

+97/−27 lines, 3 filesdep ~basedep ~constraintsdep ~lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, constraints, lens, random, ref-tf, semialign, template-haskell, these, witherable

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• reflex.cabal +2/−1
• src/Reflex/Requester/Base.hs +91/−26

@@ -1,5 +1,9 @@ # Revision history for reflex +## 0.8.2.0++* Add `matchResponseMapWithRequests`, which it similar to `matchResponsesWithRequests` but allows processing of multiple responses at once.+ ## 0.8.1.1  * Allow newer hlint for older GHCs, and add upper bound for newer GHCs

@@ -1,5 +1,5 @@ Name: reflex-Version: 0.8.1.1+Version: 0.8.2.0 Synopsis: Higher-order Functional Reactive Programming Description:   Interactive programs without callbacks or side-effects.@@ -74,6 +74,7 @@     base >= 4.11 && < 4.15,     bifunctors >= 5.2 && < 5.6,     comonad >= 5.0.4 && < 5.1,+    constraints >= 0.10 && <0.14,     constraints-extras >= 0.3 && < 0.4,     containers >= 0.6 && < 0.7,     data-default >= 0.5 && < 0.8,

@@ -1,6 +1,7 @@ -- | This module provides 'RequesterT', the standard implementation of -- 'Requester'. {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-}@@ -32,6 +33,7 @@   , requesterDataToList   , singletonRequesterData   , matchResponsesWithRequests+  , matchResponseMapWithRequests   , multiEntry   , unMultiEntry   , requesting'@@ -56,6 +58,7 @@ import Control.Monad.State.Strict import Data.Bits import Data.Coerce+import Data.Constraint import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum (DSum (..))@@ -81,19 +84,51 @@  newtype RequesterData f = RequesterData (TagMap (Entry f)) +emptyRequesterData :: RequesterData f+emptyRequesterData = RequesterData $ TagMap IntMap.empty+ data RequesterDataKey a where   RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a   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-  RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a+  RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a   RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a  singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f singletonRequesterData rdk v = case rdk of   RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v   RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v-  RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v+  RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Multi2Contents+    { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v+    , _multi2Contents_dict = Dict+    }   RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v +mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f+mergeRequesterData (RequesterData a) (RequesterData b) = RequesterData $ mergeTagMap a b++mergeTagMap :: forall f. TagMap (Entry f) -> TagMap (Entry f) -> TagMap (Entry f)+mergeTagMap (TagMap m) (TagMap n) =+  TagMap $ IntMap.unionWithKey (g' combiner) m n+  where+    combiner :: forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a+    combiner k (Entry a) (Entry b) = Entry $ case myKeyType k of+      MyTagType_Single -> a+      MyTagType_Multi -> IntMap.unionWith mergeRequesterData a b+      MyTagType_Multi2 -> case _multi2Contents_dict a of+        Dict -> Multi2Contents+          { _multi2Contents_values = Map.unionWith (IntMap.unionWith mergeRequesterData) (_multi2Contents_values a) (_multi2Contents_values b)+          , _multi2Contents_dict = Dict+          }+      MyTagType_Multi3 -> IntMap.unionWith (IntMap.unionWith mergeRequesterData) a b+    g' :: (forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a) -> Int -> Any -> Any -> Any+    g' f rawKey a b =+      let k = MyTag rawKey :: MyTag a+          fromAny :: Any -> Entry f a+          fromAny = unsafeCoerce+          toAny :: Entry f a -> Any+          toAny = unsafeCoerce+      in toAny $ f k (fromAny a) (fromAny b)+ requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f] requesterDataToList (RequesterData m) = do   k :=> Entry e <- tagMapToList m@@ -103,11 +138,12 @@       (k', e') <- IntMap.toList e       k'' :=> e'' <- requesterDataToList e'       return $ RequesterDataKey_Multi k k' k'' :=> e''-    MyTagType_Multi2 -> do-      (k', e') <- Map.toList e-      (k'', e'') <- IntMap.toList e'-      k''' :=> e''' <- requesterDataToList e''-      return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''+    MyTagType_Multi2 -> case _multi2Contents_dict e of+      Dict -> do+        (k', e') <- Map.toList $ _multi2Contents_values e+        (k'', e'') <- IntMap.toList e'+        k''' :=> e''' <- requesterDataToList e''+        return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''     MyTagType_Multi3 -> do       (k', e') <- IntMap.toList e       (k'', e'') <- IntMap.toList e'@@ -135,7 +171,13 @@         go k (Entry request) = Entry <$> case myKeyType k of           MyTagType_Single -> f request           MyTagType_Multi -> traverse (traverseRequesterData f) request-          MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request+          MyTagType_Multi2 -> case request of+            Multi2Contents { _multi2Contents_values = request', _multi2Contents_dict = Dict } -> do+              v <- traverse (traverse (traverseRequesterData f)) request'+              pure $ Multi2Contents+                { _multi2Contents_values = v+                , _multi2Contents_dict = Dict+                }           MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request  -- | 'traverseRequesterData' with its arguments flipped@@ -179,9 +221,14 @@ type family EntryContents request a where   EntryContents request (Single a) = request a   EntryContents request Multi = IntMap (RequesterData request)-  EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))+  EntryContents request (Multi2 k) = Multi2Contents k request   EntryContents request Multi3 = IntMap (IntMap (RequesterData request)) +data Multi2Contents k request = Multi2Contents+  { _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+  , _multi2Contents_values :: {-# UNPACK #-} !(Map (Some k) (IntMap (RequesterData request)))+  }+ newtype Entry request x = Entry { unEntry :: EntryContents request x }  {-# INLINE singleEntry #-}@@ -310,7 +357,7 @@   return t  {-# INLINE responseFromTag #-}-responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))+responseFromTag :: forall m t request response x. Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x)) responseFromTag (MyTagWrap t) = do   responses :: EventSelectorInt t Any <- RequesterT ask   return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t@@ -440,9 +487,9 @@       let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))           responses = fanMap $ fmapCheap unpack response           unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))-          unpack = unEntry+          unpack = _multi2Contents_values . unEntry           pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)-          pack = Entry+          pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }           f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)           f' k (Compose (n, v)) = do             (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))@@ -463,9 +510,6 @@ data Decoder rawResponse response =   forall a. Decoder (RequesterDataKey a) (rawResponse -> response a) --- | Matches incoming responses with previously-sent requests--- and uses the provided request "decoder" function to process--- incoming responses. matchResponsesWithRequests   :: forall t rawRequest rawResponse request response m.      ( MonadFix m@@ -484,7 +528,30 @@        )   -- ^ A map of outgoing wire-format requests and an event of responses keyed   -- by the 'RequesterData' key of the associated outgoing request-matchResponsesWithRequests f send recv = do+matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv++-- | Matches incoming responses with previously-sent requests+-- and uses the provided request "decoder" function to process+-- incoming responses.+matchResponseMapWithRequests+  :: forall t rawRequest rawResponse request response m.+     ( MonadFix m+     , MonadHold t m+     , Reflex t+     )+  => (forall a. request a -> (rawRequest, rawResponse -> response a))+  -- ^ Given a request (from 'Requester'), produces the wire format of the+  -- request and a function used to process the associated response+  -> Event t (RequesterData request)+  -- ^ The outgoing requests+  -> Event t (Map Int rawResponse)+  -- ^ A map of incoming responses, tagged by an identifying key+  -> m ( Event t (Map Int rawRequest)+       , Event t (RequesterData response)+       )+  -- ^ A map of outgoing wire-format requests and an event of responses keyed+  -- by the 'RequesterData' key of the associated outgoing request+matchResponseMapWithRequests f send recv = do   rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing       waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-         holdIncremental mempty $ leftmost@@ -526,17 +593,15 @@     processIncoming       :: Incremental t (PatchMap Int (Decoder rawResponse response))       -- A map of outstanding expected responses-      -> Event t (Int, rawResponse)+      -> Event t (Map Int rawResponse)       -- A incoming response paired with its identifying key       -> Event t (RequesterData response, PatchMap Int v)       -- The decoded response and a patch that clears the outstanding responses queue-    processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do+    processIncoming waitingFor inc = flip push inc $ \rspMap -> do       wf <- sample $ currentIncremental waitingFor-      case Map.lookup n wf of-        Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..-        Just (Decoder k rspF) -> do-          let rsp = rspF rawRsp-          return $ Just-            ( singletonRequesterData k rsp-            , PatchMap $ Map.singleton n Nothing-            )+      let match rawRsp (Decoder k rspF) =+            let rsp = rspF rawRsp+            in singletonRequesterData k rsp+          matches = Map.intersectionWith match rspMap wf+      pure $ if Map.null matches then Nothing else Just+        (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)