@@ -1,6 +1,7 @@
11-- | This module provides 'RequesterT', the standard implementation of
22-- 'Requester'.
33{-# LANGUAGE AllowAmbiguousTypes #-}
4+{-# LANGUAGE BangPatterns #-}
45{-# LANGUAGE CPP #-}
56{-# LANGUAGE EmptyDataDecls #-}
67{-# LANGUAGE ExistentialQuantification #-}
@@ -66,22 +67,24 @@ import Data.Proxy
6667import GHC.Exts (Any)
6768import Unsafe.Coerce
6869
70+--TODO: Make this module type-safe
71+
6972newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
7073
7174newtype RequesterData f = RequesterData (TagMap (Entry f))
7275
7376data RequesterDataKey a where
7477 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+ 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
79+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> {-# UNPACK #-} !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
80+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
7881
7982singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
8083singletonRequesterData rdk v = case rdk of
8184 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+ RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
86+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
87+ RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
8588
8689requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
8790requesterDataToList (RequesterData m) = do
@@ -89,16 +92,19 @@ requesterDataToList (RequesterData m) = do
8992 case myKeyType k of
9093 MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
9194 MyTagType_Multi -> do
92− k' :=> e' <- requesterDataToList e
93− return $ RequesterDataKey_Multi k k' :=> e'
95+ (k', e') <- IntMap.toList e
96+ k'' :=> e'' <- requesterDataToList e'
97+ return $ RequesterDataKey_Multi k k' k'' :=> e''
9498 MyTagType_Multi2 -> do
9599 (k', e') <- Map.toList e
96− k'' :=> e'' <- requesterDataToList e'
97− return $ RequesterDataKey_Multi2 k k' k'' :=> e''
100+ (k'', e'') <- IntMap.toList e'
101+ k''' :=> e''' <- requesterDataToList e''
102+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
98103 MyTagType_Multi3 -> do
99104 (k', e') <- IntMap.toList e
100− k'' :=> e'' <- requesterDataToList e'
101− return $ RequesterDataKey_Multi3 k k' k'' :=> e''
105+ (k'', e'') <- IntMap.toList e'
106+ k''' :=> e''' <- requesterDataToList e''
107+ return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''
102108
103109singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
104110singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
@@ -120,9 +126,9 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith
120126 where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
121127 go k (Entry request) = Entry <$> case myKeyType k of
122128 MyTagType_Single -> f request
123− MyTagType_Multi -> traverseRequesterData f request
124− MyTagType_Multi2 -> traverse (traverseRequesterData f) request
125− MyTagType_Multi3 -> traverse (traverseRequesterData f) request
129+ MyTagType_Multi -> traverse (traverseRequesterData f) request
130+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
131+ MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
126132
127133data MyTagType :: * -> * where
128134 MyTagType_Single :: MyTagType (Single a)
@@ -160,9 +166,9 @@ instance MyTagTypeOffset Multi3 where
160166
161167type family EntryContents request a where
162168 EntryContents request (Single a) = request a
163− EntryContents request Multi = RequesterData request
164− EntryContents request (Multi2 k) = Map (Some k) (RequesterData request)
165− EntryContents request Multi3 = IntMap (RequesterData request)
169+ EntryContents request Multi = IntMap (RequesterData request)
170+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
171+ EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
166172
167173newtype Entry request x = Entry { unEntry :: EntryContents request x }
168174
@@ -171,11 +177,11 @@ singleEntry :: f a -> Entry f (Single a)
171177singleEntry = Entry
172178
173179{-# INLINE multiEntry #-}
174−multiEntry :: RequesterData f -> Entry f Multi
180+multiEntry :: IntMap (RequesterData f) -> Entry f Multi
175181multiEntry = Entry
176182
177183{-# INLINE unMultiEntry #-}
178−unMultiEntry :: Entry f Multi -> RequesterData f
184+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
179185unMultiEntry = unEntry
180186
181187-- | 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
@@ -313,49 +319,54 @@ runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, Mona
313319 -> Event t (RequesterT t request response m b)
314320 -> RequesterT t request response m (a, Event t b)
315321runWithReplaceRequesterTWith f a0 a' = do
316− rec response <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
317− ((result0, requests0), v') <- f (runRequesterT a0 response) $ fmapCheap (`runRequesterT` response) a'
318− requests <- holdDyn requests0 $ fmapCheap snd v'
319− return (result0, fmapCheap fst v')
322+ rec na' <- numberOccurrencesFrom 1 a'
323+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
324+ let responses' = fanInt responses
325+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'
326+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'
327+ return (result0, fmapCheap (fst . snd) v')
320328
321329{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
322330traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
323331 ( Reflex t
324332 , MonadHold t m
325− , PatchTarget (p (Event t (RequesterData request))) ~ IntMap (Event t (RequesterData request))
326− , Patch (p (Event t (RequesterData request)))
333+ , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
334+ , Patch (p (Event t (IntMap (RequesterData request))))
327335 , Functor p
328336 , MonadFix m
329337 )
330− => ( (IntMap.Key -> v -> m (Event t (RequesterData request), v'))
331− -> IntMap v
332− -> Event t (p v)
333− -> RequesterT t request response m (IntMap (Event t (RequesterData request), v'), Event t (p (Event t (RequesterData request), v')))
338+ => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))
339+ -> IntMap (IntMap.Key, v)
340+ -> Event t (p (IntMap.Key, v))
341+ -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))
334342 )
335− -> (p (Event t (RequesterData request)) -> IntMap (Event t (RequesterData request)))
336− -> (Incremental t (p (Event t (RequesterData request))) -> Event t (IntMap (RequesterData request)))
343+ -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))
344+ -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))
337345 -> (IntMap.Key -> v -> RequesterT t request response m v')
338346 -> IntMap v
339347 -> Event t (p v)
340348 -> RequesterT t request response m (IntMap v', Event t (p v'))
341349traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
342350 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
343− let responses :: EventSelectorInt t (RequesterData response)
351+ let responses :: EventSelectorInt t (IntMap (RequesterData response))
344352 responses = fanInt $ fmapCheap unpack response
345− unpack :: Entry response Multi3 -> IntMap (RequesterData response)
353+ unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))
346354 unpack = unEntry
347− pack :: IntMap (RequesterData request) -> Entry request Multi3
355+ pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
348356 pack = Entry
349− f' :: IntMap.Key -> v -> m (Event t (RequesterData request), v')
350− f' k v = fmap swap $ runRequesterT (f k v) $ selectInt responses k
351− (children0, children') <- base f' dm0 dm'
357+ f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
358+ f' k (n, v) = do
359+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing fmapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?
360+ return (fmapCheap (IntMap.singleton n) myRequests, result)
361+ ndm' <- numberOccurrencesFrom 1 dm'
362+ (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 MonadAdjust
352363 let result0 = fmap snd children0
353364 result' = fforCheap children' $ fmap snd
354− requests0 :: IntMap (Event t (RequesterData request))
365+ requests0 :: IntMap (Event t (IntMap (RequesterData request)))
355366 requests0 = fmap fst children0
356− requests' :: Event t (p (Event t (RequesterData request)))
367+ requests' :: Event t (p (Event t (IntMap (RequesterData request))))
357368 requests' = fforCheap children' $ fmap fst
358− promptRequests :: Event t (IntMap (RequesterData request))
369+ promptRequests :: Event t (IntMap (IntMap (RequesterData request)))
359370 promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
360371 requests <- holdIncremental requests0 requests'
361372 return (result0, result')
@@ -365,8 +376,8 @@ traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v
365376 ( GCompare k
366377 , Reflex t
367378 , MonadHold t m
368− , PatchTarget (p' (Some k) (Event t (RequesterData request))) ~ Map (Some k) (Event t (RequesterData request))
369− , Patch (p' (Some k) (Event t (RequesterData request)))
379+ , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))
380+ , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))
370381 , MonadFix m
371382 )
372383 => (forall k' v1 v2. GCompare k'
@@ -375,7 +386,7 @@ traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v
375386 -> Event t (p k' v1)
376387 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
377388 )
378− -> (forall v1. (forall a. v1 a -> v' a) -> p k v1 -> p k v')
389+ -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)
379390 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
380391 -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
381392 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
@@ -385,22 +396,25 @@ traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v
385396 -> RequesterT t request response m (DMap k v', Event t (p k v'))
386397traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
387398 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
388− let responses :: EventSelector t (Const2 (Some k) (RequesterData response))
399+ let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
389400 responses = fanMap $ fmapCheap unpack response
390− unpack :: Entry response (Multi2 k) -> Map (Some k) (RequesterData response)
401+ unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
391402 unpack = unEntry
392− pack :: Map (Some k) (RequesterData request) -> Entry request (Multi2 k)
403+ pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
393404 pack = Entry
394− f' :: forall a. k a -> v a -> m (Compose ((,) (Event t (RequesterData request))) v' a)
395− f' k v = fmap (Compose . swap) $ runRequesterT (f k v) $ select responses (Const2 (Some.This k))
396− (children0, children') <- base f' dm0 dm'
405+ f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
406+ f' k (Compose (n, v)) = do
407+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))
408+ return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
409+ ndm' <- numberOccurrencesFrom 1 dm'
410+ (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
397411 let result0 = DMap.map (snd . getCompose) children0
398412 result' = fforCheap children' $ mapPatch $ snd . getCompose
399− requests0 :: Map (Some k) (Event t (RequesterData request))
413+ requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))
400414 requests0 = weakenDMapWith (fst . getCompose) children0
401− requests' :: Event t (p' (Some k) (Event t (RequesterData request)))
415+ requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))
402416 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
403− promptRequests :: Event t (Map (Some k) (RequesterData request))
417+ promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))
404418 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
405419 requests <- holdIncremental requests0 requests'
406420 return (result0, result')