Internal.hs

-- | This module provides 'RequesterT', the standard implementation of
-- 'Requester'.
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Reflex.Requester.Base.Internal where

import Control.Monad
import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)
import Control.Monad.Exception
import Control.Monad.Fix
import Control.Monad.Identity
import Control.Monad.Morph
import Control.Monad.Primitive
import Control.Monad.Reader
import Control.Monad.Ref
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 (..))
import Data.Functor.Compose
import Data.Functor.Misc
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.Kind (Type)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Proxy
import Data.Some (Some(Some))
import Data.Type.Equality
import Data.Unique.Tag

import GHC.Exts (Any)
import Unsafe.Coerce

#if !MIN_VERSION_base(4,18,0)
import Control.Applicative (liftA2)
import Data.Monoid ((<>))
#endif

import Reflex.Class
import Reflex.Adjustable.Class
import Reflex.Dynamic
import Reflex.EventWriter.Class
import Reflex.Host.Class
import Reflex.PerformEvent.Class
import Reflex.PostBuild.Class
import Reflex.Requester.Class
import Reflex.TriggerEvent.Class

--TODO: Make this module type-safe

newtype TagMap (f :: Type -> Type) = TagMap (IntMap Any)

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 :: 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 $ 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
  case myKeyType k of
    MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
    MyTagType_Multi -> do
      (k', e') <- IntMap.toList e
      k'' :=> e'' <- requesterDataToList e'
      return $ RequesterDataKey_Multi 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'
      k''' :=> e''' <- requesterDataToList e''
      return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''

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

tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
tagMapToList (TagMap m) = f <$> IntMap.toList m
  where f :: (Int, Any) -> DSum MyTag f
        f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v

traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
  where
    g :: Int -> Any -> t Any
    g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)

-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order
  where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
        go k (Entry request) = Entry <$> case myKeyType k of
          MyTagType_Single -> f request
          MyTagType_Multi -> 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
forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)
forRequesterData r f = traverseRequesterData f r

data MyTagType :: Type -> Type where
  MyTagType_Single :: MyTagType (Single a)
  MyTagType_Multi :: MyTagType Multi
  MyTagType_Multi2 :: MyTagType (Multi2 k)
  MyTagType_Multi3 :: MyTagType Multi3

myKeyType :: MyTag x -> MyTagType x
myKeyType (MyTag k) = case k .&. 0x3 of
  0x0 -> unsafeCoerce MyTagType_Single
  0x1 -> unsafeCoerce MyTagType_Multi
  0x2 -> unsafeCoerce MyTagType_Multi2
  0x3 -> unsafeCoerce MyTagType_Multi3
  t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t

data Single a
data Multi
data Multi2 (k :: Type -> Type)
data Multi3

class MyTagTypeOffset x where
  myTagTypeOffset :: proxy x -> Int

instance MyTagTypeOffset (Single a) where
  myTagTypeOffset _ = 0x0

instance MyTagTypeOffset Multi where
  myTagTypeOffset _ = 0x1

instance MyTagTypeOffset (Multi2 k) where
  myTagTypeOffset _ = 0x2

instance MyTagTypeOffset Multi3 where
  myTagTypeOffset _ = 0x3

type family EntryContents request a where
  EntryContents request (Single a) = request a
  EntryContents request Multi = 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 #-}
singleEntry :: f a -> Entry f (Single a)
singleEntry = Entry

{-# INLINE multiEntry #-}
multiEntry :: IntMap (RequesterData f) -> Entry f Multi
multiEntry = Entry

{-# INLINE unMultiEntry #-}
unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
unMultiEntry = unEntry

-- | 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
-- 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
newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

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

{-# INLINE castMyTagWrap #-}
castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
castMyTagWrap = coerce

instance GEq MyTag where
  (MyTag a) `geq` (MyTag b) =
    if a == b
    then Just $ unsafeCoerce Refl
    else Nothing

instance GCompare MyTag where
  (MyTag a) `gcompare` (MyTag b) =
    case a `compare` b of
      LT -> GLT
      EQ -> unsafeCoerce GEQ
      GT -> GGT

instance GEq (MyTagWrap f) where
  (MyTagWrap a) `geq` (MyTagWrap b) =
    if a == b
    then Just $ unsafeCoerce Refl
    else Nothing

instance GCompare (MyTagWrap f) where
  (MyTagWrap a) `gcompare` (MyTagWrap b) =
    case a `compare` b of
      LT -> GLT
      EQ -> unsafeCoerce GEQ
      GT -> GGT

data RequesterState t (request :: Type -> Type) = RequesterState
  { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
  , _requesterState_requests :: ![(Int, Event t Any)]
  }

-- | A basic implementation of 'Requester'.
newtype RequesterT t request (response :: Type -> Type) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }
  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
           , MonadAsyncException
           , MonadCatch
           , MonadThrow
           , MonadMask
           )

deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

instance EventWriter t w m => EventWriter t w (RequesterT t request response m) where
  tellEvent = lift . tellEvent

instance PrimMonad m => PrimMonad (RequesterT t request response m) where
  type PrimState (RequesterT t request response m) = PrimState m
  primitive = lift . primitive

-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
  mempty = pure mempty

instance (Semigroup a, Monad m) => Semigroup (RequesterT t request response m a) where
  (<>) = liftA2 (<>)


-- | Run a 'RequesterT' action.  The resulting 'Event' will fire whenever
-- requests are made, and responses should be provided in the input 'Event'.
-- The 'Tag' keys will be used to return the responses to the same place the
-- requests were issued.
runRequesterT :: (Reflex t, Monad m)
              => RequesterT t request response m a
              -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
              -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
runRequesterT (RequesterT a) responses = do
  (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $
    coerceEvent responses
  return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

-- | Map a function over the request and response of a 'RequesterT'
withRequesterT
  :: (Reflex t, MonadFix m)
  => (forall x. req x -> req' x) -- ^ The function to map over the request
  -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response
  -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed
  -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'
withRequesterT freq frsp child = do
  rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'
      (a, req) <- lift $ runRequesterT child rsp
      rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $
        fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req
  return a

instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
  type Request (RequesterT t request response m) = request
  type Response (RequesterT t request response m) = response
  requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
  requesting_ = void . tagRequest . fmapCheap singleEntry

{-# INLINE tagRequest #-}
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))
tagRequest req = do
  old <- RequesterT get
  let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
      t = MyTagWrap n
  RequesterT $ put $ RequesterState
    { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4
    , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old
    }
  return t

{-# INLINE responseFromTag #-}
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

instance MonadTrans (RequesterT t request response) where
  lift = RequesterT . lift . lift

instance MFunctor (RequesterT t request response) where
  hoist f = RequesterT . hoist (hoist f) . unRequesterT

instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
  type Performable (RequesterT t request response m) = Performable m
  performEvent_ = lift . performEvent_
  performEvent = lift . performEvent

instance MonadRef m => MonadRef (RequesterT t request response m) where
  type Ref (RequesterT t request response m) = Ref m
  newRef = lift . newRef
  readRef = lift . readRef
  writeRef r = lift . writeRef r

instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
  newEventWithTrigger = lift . newEventWithTrigger
  newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

instance MonadReader r m => MonadReader r (RequesterT t request response m) where
  ask = lift ask
  local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
  reader = lift . reader

instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where
  runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
  traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental
  {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
  traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
  traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
requesting' = responseFromTag . castMyTagWrap <=< tagRequest

{-# INLINABLE runWithReplaceRequesterTWith #-}
runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
                                                                 , MonadFix m
                                                                 )
                             => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
                             -> RequesterT t request response m a
                             -> Event t (RequesterT t request response m b)
                             -> RequesterT t request response m (a, Event t b)
runWithReplaceRequesterTWith f a0 a' = do
  rec na' <- numberOccurrencesFrom 1 a'
      responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
      let responses' = fanInt responses
      ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'
      requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'
  return (result0, fmapCheap (fst . snd) v')

{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
                                        ( Reflex t
                                        , MonadHold t m
                                        , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
                                        , Patch (p (Event t (IntMap (RequesterData request))))
                                        , Functor p
                                        , MonadFix m
                                        )
                                     => (   (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))
                                         -> IntMap (IntMap.Key, v)
                                         -> Event t (p (IntMap.Key, v))
                                         -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))
                                        )
                                     -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))
                                     -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))
                                     -> (IntMap.Key -> v -> RequesterT t request response m v')
                                     -> IntMap v
                                     -> Event t (p v)
                                     -> RequesterT t request response m (IntMap v', Event t (p v'))
traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
  rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
      let responses :: EventSelectorInt t (IntMap (RequesterData response))
          responses = fanInt $ fmapCheap unpack response
          unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))
          unpack = unEntry
          pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
          pack = Entry
          f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
          f' k (n, v) = do
            (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?
            return (fmapCheap (IntMap.singleton n) myRequests, result)
      ndm' <- numberOccurrencesFrom 1 dm'
      (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
      let result0 = fmap snd children0
          result' = fforCheap children' $ fmap snd
          requests0 :: IntMap (Event t (IntMap (RequesterData request)))
          requests0 = fmap fst children0
          requests' :: Event t (p (Event t (IntMap (RequesterData request))))
          requests' = fforCheap children' $ fmap fst
          promptRequests :: Event t (IntMap (IntMap (RequesterData request)))
          promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
      requests <- holdIncremental requests0 requests'
  return (result0, result')

{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
                                        ( GCompare k
                                        , Reflex t
                                        , MonadHold t m
                                        , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))
                                        , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))
                                        , MonadFix m
                                        )
                                     => (forall k' v1 v2. GCompare k'
                                         => (forall a. k' a -> v1 a -> m (v2 a))
                                         -> DMap k' v1
                                         -> Event t (p k' v1)
                                         -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
                                        )
                                     -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)
                                     -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
                                     -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
                                     -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
                                     -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
                                     -> DMap k v
                                     -> Event t (p k v)
                                     -> RequesterT t request response m (DMap k v', Event t (p k v'))
traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
  rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
      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 = _multi2Contents_values . unEntry
          pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
          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))
            return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
      ndm' <- numberOccurrencesFrom 1 dm'
      (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
      let result0 = DMap.map (snd . getCompose) children0
          result' = fforCheap children' $ mapPatch $ snd . getCompose
          requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))
          requests0 = weakenDMapWith (fst . getCompose) children0
          requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))
          requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
          promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))
          promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
      requests <- holdIncremental requests0 requests'
  return (result0, result')

data Decoder rawResponse response =
  forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

matchResponsesWithRequests
  :: 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 (Int, rawResponse)
  -- ^ The 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
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
          [ fmap (\(_, outstanding, _) -> outstanding) outgoing
          , snd <$> incoming
          ]
      let outgoing = processOutgoing nextId send
          incoming = processIncoming waitingFor recv
  return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)
  where
    -- Tags each outgoing request with an identifying integer key
    -- and returns the next available key, a map of response decoders
    -- for requests for which there are outstanding responses, and the
    -- raw requests to be sent out.
    processOutgoing
      :: Behavior t Int
      -- The next available key
      -> Event t (RequesterData request)
      -- The outgoing request
      -> Event t ( Int
                 , PatchMap Int (Decoder rawResponse response)
                 , Map Int rawRequest )
      -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests
    processOutgoing nextId out = flip pushAlways out $ \dm -> do
      oldNextId <- sample nextId
      let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do
            n <- get
            put $ succ n
            let (rawReq, rspF) = f v
            return (n, rawReq, Decoder k rspF)
          patchWaitingFor = PatchMap $ Map.fromList $
            (\(n, _, dec) -> (n, Just dec)) <$> result
          toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result
      return (newNextId, patchWaitingFor, toSend)
    -- Looks up the each incoming raw response in a map of response
    -- decoders and returns the decoded response and a patch that can
    -- be used to clear the ID of the consumed response out of the queue
    -- of expected responses.
    processIncoming
      :: Incremental t (PatchMap Int (Decoder rawResponse response))
      -- A map of outstanding expected responses
      -> 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 $ \rspMap -> do
      wf <- sample $ currentIncremental waitingFor
      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)