reflex 0.8.2.2 → 0.9.0.0
raw patch · 5 files changed
+620/−606 lines, 5 filesdep ~basedep ~hlintdep ~lens
Dependency ranges changed: base, hlint, lens, template-haskell, time
Files
- ChangeLog.md +6/−0
- reflex.cabal +11/−10
- src/Reflex/Collection.hs +8/−8
- src/Reflex/Requester/Base.hs +1/−588
- src/Reflex/Requester/Base/Internal.hs +594/−0
ChangeLog.md view
@@ -1,5 +1,11 @@ # Revision history for reflex +## 0.9.0.0++* Breaking Change: Filter updates to `listWithKey` child widgets so that changes to the input Map don't cause spurious updates to unaffected children. This imposes an `Eq` constraint on the child values.+* Expose all Requester internals in Reflex.Requester.Base.Internal+* [Add EventWriter instance for RequesterT #469](https://github.com/reflex-frp/reflex/pull/469)+ ## 0.8.2.2 * Require witherable >= 0.4 and, hence, a newer monoidal-containers
reflex.cabal view
@@ -1,5 +1,5 @@ Name: reflex-Version: 0.8.2.2+Version: 0.9.0.0 Synopsis: Higher-order Functional Reactive Programming Description: Interactive programs without callbacks or side-effects.@@ -28,8 +28,8 @@ ChangeLog.md tested-with:- GHC ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.2 || ==9.0.1 || ==9.2.2,- GHCJS ==8.6+ GHC ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.7 || ==9.0.1 || ==9.2.5 || ==9.4.3,+ GHCJS ==8.6 || ==8.10 flag use-reflex-optimizer description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.@@ -71,7 +71,7 @@ hs-source-dirs: src build-depends: MemoTrie == 0.6.*,- base >= 4.11 && < 4.17,+ base >= 4.11 && < 4.18, bifunctors >= 5.2 && < 5.6, comonad >= 5.0.4 && < 5.1, commutative-semigroups >= 0.1 && <0.2,@@ -81,7 +81,7 @@ data-default >= 0.5 && < 0.8, dependent-map >= 0.3 && < 0.5, exception-transformers == 0.4.*,- lens >= 4.7 && < 5.2,+ lens >= 4.7 && < 5.3, mmorph >= 1.0 && < 1.2, monad-control >= 1.0.1 && < 1.1, mtl >= 2.1 && < 2.3,@@ -95,7 +95,7 @@ semigroupoids >= 4.0 && < 6, stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8,- time >= 1.4 && < 1.12,+ time >= 1.4 && < 1.13, transformers >= 0.5.6.0 && < 0.6, unbounded-delays >= 0.1.0.0 && < 0.2, witherable >= 0.4 && < 0.5@@ -144,6 +144,7 @@ Reflex.Query.Base, Reflex.Query.Class, Reflex.Requester.Base,+ Reflex.Requester.Base.Internal, Reflex.Requester.Class, Reflex.Spider, Reflex.Spider.Internal,@@ -187,7 +188,7 @@ dependent-sum >= 0.6 && < 0.8, haskell-src-exts >= 1.16 && < 1.24, haskell-src-meta >= 0.6 && < 0.9,- template-haskell >= 2.9 && < 2.19+ template-haskell >= 2.9 && < 2.20 exposed-modules: Reflex.Dynamic.TH other-extensions: TemplateHaskell@@ -259,10 +260,10 @@ , directory , filepath , filemanip- if impl(ghc >= 8.8)- build-depends: hlint >= 3 && < 4+ if impl(ghc < 9.2)+ build-depends: hlint (< 2.1 || >= 2.2.2) && < 3.5 else- build-depends: hlint (< 2.1 || >= 2.2.2) && < 4+ build-depends: hlint >= 3.5 && < 3.6 if impl(ghcjs) buildable: False
src/Reflex/Collection.hs view
@@ -74,7 +74,7 @@ --where the Events carry diffs, not the whole value listWithKey :: forall t k v m a- . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m)+ . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m, Eq v) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))@@ -106,7 +106,7 @@ , tag (current vals) postBuild ] listHoldWithKey Map.empty changeVals $ \k v ->- mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)+ mkChild k =<< holdUniqDyn =<< holdDyn v (select childValChangedSelector $ Const2 k) -- | Display the given map of items (in key order) using the builder -- function provided, and update it with the given event. 'Nothing'@@ -147,7 +147,7 @@ -- this scenario, but 'listViewWithKey' flattens this to -- @/Event t (Map k a)/@ via 'switch'. listViewWithKey- :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)+ :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m, Eq v) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))@@ -155,7 +155,7 @@ switch . fmap mergeMap <$> listViewWithKey' vals mkChild listViewWithKey'- :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)+ :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m, Eq v) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))@@ -165,7 +165,7 @@ -- selected at any time. selectViewListWithKey :: forall t m k v a- . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)+ . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m, Eq v) => Dynamic t k -- ^ Current selection key -> Dynamic t (Map k v)@@ -189,7 +189,7 @@ -- item widget's output 'Event'. selectViewListWithKey_ :: forall t m k v a- . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)+ . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m, Eq v) => Dynamic t k -- ^ Current selection key -> Dynamic t (Map k v)@@ -207,7 +207,7 @@ -- key/value map. Unlike the 'withKey' variants, the child widgets -- are insensitive to which key they're associated with. list- :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)+ :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m, Eq v) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))@@ -215,7 +215,7 @@ -- | Create a dynamically-changing set of widgets from a Dynamic list. simpleList- :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)+ :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m, Eq v) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
src/Reflex/Requester/Base.hs view
@@ -1,24 +1,3 @@--- | 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 #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif module Reflex.Requester.Base ( RequesterT (..) , runRequesterT@@ -39,570 +18,4 @@ , requesting' ) where -import Reflex.Class-import Reflex.Adjustable.Class-import Reflex.Dynamic-import Reflex.Host.Class-import Reflex.PerformEvent.Class-import Reflex.PostBuild.Class-import Reflex.Requester.Class-import Reflex.TriggerEvent.Class--import Control.Applicative (liftA2)-import Control.Monad.Exception-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.Monoid ((<>))-import Data.Proxy-import qualified Data.Semigroup as S-import Data.Some (Some(Some))-import Data.Type.Equality-import Data.Unique.Tag--import GHC.Exts (Any)-import Unsafe.Coerce----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 can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2-#if MIN_VERSION_base(4,9,1)- , MonadAsyncException-#endif- )--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 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- mappend = liftA2 mappend--instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where- (<>) = liftA2 (S.<>)----- | 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)+import Reflex.Requester.Base.Internal
+ src/Reflex/Requester/Base/Internal.hs view
@@ -0,0 +1,594 @@+-- | 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 #-}+#ifdef USE_REFLEX_OPTIMIZER+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}+#endif+module Reflex.Requester.Base.Internal where++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++import Control.Applicative (liftA2)+import Control.Monad.Exception+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.Monoid ((<>))+import Data.Proxy+import qualified Data.Semigroup as S+import Data.Some (Some(Some))+import Data.Type.Equality+import Data.Unique.Tag++import GHC.Exts (Any)+import Unsafe.Coerce++--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 can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2+#if MIN_VERSION_base(4,9,1)+ , MonadAsyncException+#endif+ )++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+ mappend = liftA2 mappend++instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where+ (<>) = liftA2 (S.<>)+++-- | 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)