b02dbfa · patch · git.iko.soy

1-- | This module provides 'RequesterT', the standard implementation of

2-- 'Requester'.

3{-# LANGUAGE AllowAmbiguousTypes #-}

4+{-# LANGUAGE BangPatterns #-}

4{-# LANGUAGE CPP #-}

5{-# LANGUAGE CPP #-}

5{-# LANGUAGE EmptyDataDecls #-}

6{-# LANGUAGE EmptyDataDecls #-}

6{-# LANGUAGE ExistentialQuantification #-}

7{-# LANGUAGE ExistentialQuantification #-}

66import GHC.Exts (Any)

67import GHC.Exts (Any)

67import Unsafe.Coerce

68import Unsafe.Coerce

68

69

70+--TODO: Make this module type-safe

71+

69newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

72newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

70

73

71newtype RequesterData f = RequesterData (TagMap (Entry f))

74newtype RequesterData f = RequesterData (TagMap (Entry f))

72

75

73data RequesterDataKey a where

76data RequesterDataKey a where

74 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

77 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

75− RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> !(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

76− RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> {-# UNPACK #-} !(Some k) -> !(RequesterDataKey a) -> RequesterDataKey a

79+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> {-# UNPACK #-} !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

77− RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> Int -> !(RequesterDataKey a) -> RequesterDataKey a

80+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

78

81

79singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

82singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

80singletonRequesterData rdk v = case rdk of

83singletonRequesterData rdk v = case rdk of

81 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

84 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

82− RequesterDataKey_Multi k k' -> RequesterData $ singletonTagMap k $ Entry $ singletonRequesterData k' v

85+ RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

83− RequesterDataKey_Multi2 k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ Map.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

84− RequesterDataKey_Multi3 k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ 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

85

88

86requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

89requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

87requesterDataToList (RequesterData m) = do

90requesterDataToList (RequesterData m) = do

89 case myKeyType k of

92 case myKeyType k of

90 MyTagType_Single -> return $ RequesterDataKey_Single k :=> e

93 MyTagType_Single -> return $ RequesterDataKey_Single k :=> e

91 MyTagType_Multi -> do

94 MyTagType_Multi -> do

95+ (k', e') <- IntMap.toList e

92− k' :=> e' <- requesterDataToList e

96+ k'' :=> e'' <- requesterDataToList e'

93− return $ RequesterDataKey_Multi k k' :=> e'

97+ return $ RequesterDataKey_Multi k k' k'' :=> e''

94 MyTagType_Multi2 -> do

98 MyTagType_Multi2 -> do

95 (k', e') <- Map.toList e

99 (k', e') <- Map.toList e

100+ (k'', e'') <- IntMap.toList e'

96− k'' :=> e'' <- requesterDataToList e'

101+ k''' :=> e''' <- requesterDataToList e''

97− return $ RequesterDataKey_Multi2 k k' k'' :=> e''

102+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

98 MyTagType_Multi3 -> do

103 MyTagType_Multi3 -> do

99 (k', e') <- IntMap.toList e

104 (k', e') <- IntMap.toList e

105+ (k'', e'') <- IntMap.toList e'

100− k'' :=> e'' <- requesterDataToList e'

106+ k''' :=> e''' <- requesterDataToList e''

101− return $ RequesterDataKey_Multi3 k k' k'' :=> e''

107+ return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''

102

108

103singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

109singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

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

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

120 where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

126 where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

121 go k (Entry request) = Entry <$> case myKeyType k of

127 go k (Entry request) = Entry <$> case myKeyType k of

122 MyTagType_Single -> f request

128 MyTagType_Single -> f request

123− MyTagType_Multi -> traverseRequesterData f request

129+ MyTagType_Multi -> traverse (traverseRequesterData f) request

124− MyTagType_Multi2 -> traverse (traverseRequesterData f) request

130+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

125− MyTagType_Multi3 -> traverse (traverseRequesterData f) request

131+ MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

126

132

127data MyTagType :: * -> * where

133data MyTagType :: * -> * where

128 MyTagType_Single :: MyTagType (Single a)

134 MyTagType_Single :: MyTagType (Single a)

160

166

161type family EntryContents request a where

167type family EntryContents request a where

162 EntryContents request (Single a) = request a

168 EntryContents request (Single a) = request a

163− EntryContents request Multi = RequesterData request

169+ EntryContents request Multi = IntMap (RequesterData request)

164− EntryContents request (Multi2 k) = Map (Some k) (RequesterData request)

170+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))

165− EntryContents request Multi3 = IntMap (RequesterData request)

171+ EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

166

172

167newtype Entry request x = Entry { unEntry :: EntryContents request x }

173newtype Entry request x = Entry { unEntry :: EntryContents request x }

168

174

171singleEntry = Entry

177singleEntry = Entry

172

178

173{-# INLINE multiEntry #-}

179{-# INLINE multiEntry #-}

174−multiEntry :: RequesterData f -> Entry f Multi

180+multiEntry :: IntMap (RequesterData f) -> Entry f Multi

175multiEntry = Entry

181multiEntry = Entry

176

182

177{-# INLINE unMultiEntry #-}

183{-# INLINE unMultiEntry #-}

178−unMultiEntry :: Entry f Multi -> RequesterData f

184+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)

179unMultiEntry = unEntry

185unMultiEntry = unEntry

180

186

181-- | 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

187-- | 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 -> Event t (RequesterT t request response m b)

319 -> Event t (RequesterT t request response m b)

314 -> RequesterT t request response m (a, Event t b)

320 -> RequesterT t request response m (a, Event t b)

315runWithReplaceRequesterTWith f a0 a' = do

321runWithReplaceRequesterTWith f a0 a' = do

322+ rec na' <- numberOccurrencesFrom 1 a'

316− rec response <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

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

317− ((result0, requests0), v') <- f (runRequesterT a0 response) $ fmapCheap (`runRequesterT` response) a'

325+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'

318− requests <- holdDyn requests0 $ fmapCheap snd v'

326+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'

319− return (result0, fmapCheap fst v')

327+ return (result0, fmapCheap (fst . snd) v')

320

328

321{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

329{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

322traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

330traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

323 ( Reflex t

331 ( Reflex t

324 , MonadHold t m

332 , MonadHold t m

325− , PatchTarget (p (Event t (RequesterData request))) ~ IntMap (Event t (RequesterData request))

333+ , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))

326− , Patch (p (Event t (RequesterData request)))

334+ , Patch (p (Event t (IntMap (RequesterData request))))

327 , Functor p

335 , Functor p

328 , MonadFix m

336 , MonadFix m

329 )

337 )

330− => ( (IntMap.Key -> v -> m (Event t (RequesterData request), v'))

338+ => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))

331− -> IntMap v

339+ -> IntMap (IntMap.Key, v)

332− -> Event t (p v)

340+ -> Event t (p (IntMap.Key, v))

333− -> RequesterT t request response m (IntMap (Event t (RequesterData request), v'), Event t (p (Event t (RequesterData request), v')))

341+ -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))

334 )

342 )

335− -> (p (Event t (RequesterData request)) -> IntMap (Event t (RequesterData request)))

343+ -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))

336− -> (Incremental t (p (Event t (RequesterData request))) -> Event t (IntMap (RequesterData request)))

344+ -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))

337 -> (IntMap.Key -> v -> RequesterT t request response m v')

345 -> (IntMap.Key -> v -> RequesterT t request response m v')

338 -> IntMap v

346 -> IntMap v

339 -> Event t (p v)

347 -> Event t (p v)

340 -> RequesterT t request response m (IntMap v', Event t (p v'))

348 -> RequesterT t request response m (IntMap v', Event t (p v'))

341traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

349traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

342 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

350 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))

344 responses = fanInt $ fmapCheap unpack response

352 responses = fanInt $ fmapCheap unpack response

345− unpack :: Entry response Multi3 -> IntMap (RequesterData response)

353+ unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))

346 unpack = unEntry

354 unpack = unEntry

347− pack :: IntMap (RequesterData request) -> Entry request Multi3

355+ pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3

348 pack = Entry

356 pack = Entry

349− f' :: IntMap.Key -> v -> m (Event t (RequesterData request), v')

357+ f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

350− f' k v = fmap swap $ runRequesterT (f k v) $ selectInt responses k

358+ f' k (n, v) = do

351− (children0, children') <- base f' dm0 dm'

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

352 let result0 = fmap snd children0

363 let result0 = fmap snd children0

353 result' = fforCheap children' $ fmap snd

364 result' = fforCheap children' $ fmap snd

354− requests0 :: IntMap (Event t (RequesterData request))

365+ requests0 :: IntMap (Event t (IntMap (RequesterData request)))

355 requests0 = fmap fst children0

366 requests0 = fmap fst children0

356− requests' :: Event t (p (Event t (RequesterData request)))

367+ requests' :: Event t (p (Event t (IntMap (RequesterData request))))

357 requests' = fforCheap children' $ fmap fst

368 requests' = fforCheap children' $ fmap fst

358− promptRequests :: Event t (IntMap (RequesterData request))

369+ promptRequests :: Event t (IntMap (IntMap (RequesterData request)))

359 promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

370 promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

360 requests <- holdIncremental requests0 requests'

371 requests <- holdIncremental requests0 requests'

361 return (result0, result')

372 return (result0, result')

365 ( GCompare k

376 ( GCompare k

366 , Reflex t

377 , Reflex t

367 , MonadHold t m

378 , MonadHold t m

368− , PatchTarget (p' (Some k) (Event t (RequesterData request))) ~ Map (Some k) (Event t (RequesterData request))

379+ , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))

369− , Patch (p' (Some k) (Event t (RequesterData request)))

380+ , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))

370 , MonadFix m

381 , MonadFix m

371 )

382 )

372 => (forall k' v1 v2. GCompare k'

383 => (forall k' v1 v2. GCompare k'

375 -> Event t (p k' v1)

386 -> Event t (p k' v1)

376 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

387 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

377 )

388 )

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)

379 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

390 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

380 -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)

391 -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)

381 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

392 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

385 -> RequesterT t request response m (DMap k v', Event t (p k v'))

396 -> RequesterT t request response m (DMap k v', Event t (p k v'))

386traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

397traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

387 rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

398 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)))

389 responses = fanMap $ fmapCheap unpack response

400 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))

391 unpack = unEntry

402 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)

393 pack = Entry

404 pack = Entry

394− f' :: forall a. k a -> v a -> m (Compose ((,) (Event t (RequesterData request))) v' a)

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

395− f' k v = fmap (Compose . swap) $ runRequesterT (f k v) $ select responses (Const2 (Some.This k))

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'

396− (children0, children') <- base f' dm0 dm'

410+ (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

397 let result0 = DMap.map (snd . getCompose) children0

411 let result0 = DMap.map (snd . getCompose) children0

398 result' = fforCheap children' $ mapPatch $ snd . getCompose

412 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)))

400 requests0 = weakenDMapWith (fst . getCompose) children0

414 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))))

402 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

416 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)))

404 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

418 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

405 requests <- holdIncremental requests0 requests'

419 requests <- holdIncremental requests0 requests'

406 return (result0, result')

420 return (result0, result')