@@ -25,7 +25,10 @@ module Reflex.Requester.Base
2525 , traverseIntMapWithKeyWithAdjustRequesterTWith
2626 , traverseDMapWithKeyWithAdjustRequesterTWith
2727 , RequesterData
28+ , RequesterDataKey
2829 , traverseRequesterData
30+ , requesterDataToList
31+ , singletonRequesterData
2932 ) where
3033
3134import Reflex.Class
@@ -43,7 +46,7 @@ import Control.Monad.Ref
4346import Control.Monad.State.Strict
4447import Data.Bits
4548import Data.Coerce
46−import Data.Dependent.Map (DMap)
49+import Data.Dependent.Map (DMap, DSum (..))
4750import qualified Data.Dependent.Map as DMap
4851import qualified Data.Some as Some
4952import Data.FastMutableIntMap
@@ -52,6 +55,7 @@ import Data.Functor.Misc
5255import Data.IntMap.Strict (IntMap)
5356import qualified Data.IntMap.Strict as IntMap
5457import Data.Map (Map)
58+import qualified Data.Map as Map
5559import Data.Monoid ((<>))
5660import Data.Unique.Tag
5761import Data.Some (Some)
@@ -66,6 +70,44 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
6670
6771newtype RequesterData f = RequesterData (TagMap (Entry f))
6872
73+data RequesterDataKey a where
74+ RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
75+ RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> !(RequesterDataKey a) -> RequesterDataKey a
76+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> {-# UNPACK #-} !(Some k) -> !(RequesterDataKey a) -> RequesterDataKey a
77+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> Int -> !(RequesterDataKey a) -> RequesterDataKey a
78+
79+singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
80+singletonRequesterData rdk v = case rdk of
81+ RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
82+ RequesterDataKey_Multi k k' -> RequesterData $ singletonTagMap k $ Entry $ singletonRequesterData k' v
83+ RequesterDataKey_Multi2 k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ singletonRequesterData k'' v
84+ RequesterDataKey_Multi3 k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
85+
86+requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
87+requesterDataToList (RequesterData m) = do
88+ k :=> Entry e <- tagMapToList m
89+ case myKeyType k of
90+ MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
91+ MyTagType_Multi -> do
92+ k' :=> e' <- requesterDataToList e
93+ return $ RequesterDataKey_Multi k k' :=> e'
94+ MyTagType_Multi2 -> do
95+ (k', e') <- Map.toList e
96+ k'' :=> e'' <- requesterDataToList e'
97+ return $ RequesterDataKey_Multi2 k k' k'' :=> e''
98+ MyTagType_Multi3 -> do
99+ (k', e') <- IntMap.toList e
100+ k'' :=> e'' <- requesterDataToList e'
101+ return $ RequesterDataKey_Multi3 k k' k'' :=> e''
102+
103+singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
104+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
105+
106+tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
107+tagMapToList (TagMap m) = fmap f $ IntMap.toList m
108+ where f :: (Int, Any) -> DSum MyTag f
109+ f (k, v) = MyTag k :=> ((unsafeCoerce :: Any -> f a) v)
110+
69111traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
70112traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
71113 where
@@ -132,6 +174,10 @@ singleEntry = Entry
132174multiEntry :: RequesterData f -> Entry f Multi
133175multiEntry = Entry
134176
177+{-# INLINE unMultiEntry #-}
178+unMultiEntry :: Entry f Multi -> RequesterData f
179+unMultiEntry = unEntry
180+
135181-- | 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
136182-- 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
137183newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
@@ -267,7 +313,7 @@ runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, Mona
267313 -> Event t (RequesterT t request response m b)
268314 -> RequesterT t request response m (a, Event t b)
269315runWithReplaceRequesterTWith f a0 a' = do
270− rec response <- fmap (fmapCheap unEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
316+ rec response <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
271317 ((result0, requests0), v') <- f (runRequesterT a0 response) $ fmapCheap (`runRequesterT` response) a'
272318 requests <- holdDyn requests0 $ fmapCheap snd v'
273319 return (result0, fmapCheap fst v')