@@ -1,16 +1,20 @@
11-- | This module provides 'RequesterT', the standard implementation of
22-- 'Requester'.
3−{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE AllowAmbiguousTypes #-}
44{-# LANGUAGE CPP #-}
5+{-# LANGUAGE EmptyDataDecls #-}
56{-# LANGUAGE ExistentialQuantification #-}
67{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE GADTs #-}
79{-# LANGUAGE GeneralizedNewtypeDeriving #-}
810{-# LANGUAGE MultiParamTypeClasses #-}
911{-# LANGUAGE Rank2Types #-}
12+{-# LANGUAGE RecursiveDo #-}
1013{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
1115{-# LANGUAGE TypeFamilies #-}
16+{-# LANGUAGE TypeOperators #-}
1217{-# LANGUAGE UndecidableInstances #-}
13−{-# LANGUAGE StandaloneDeriving #-}
1418#ifdef USE_REFLEX_OPTIMIZER
1519{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1620#endif
@@ -18,11 +22,13 @@ module Reflex.Requester.Base
1822 ( RequesterT (..)
1923 , runRequesterT
2024 , runWithReplaceRequesterTWith
21− , sequenceDMapWithAdjustRequesterTWith
25+ , traverseDMapWithKeyWithAdjustRequesterTWith
26+ , RequesterData
27+ , traverseRequesterData
2228 ) where
2329
2430import Reflex.Class
25−import Reflex.EventWriter
31+import Reflex.Dynamic
2632import Reflex.Host.Class
2733import Reflex.PerformEvent.Class
2834import Reflex.PostBuild.Class
@@ -31,20 +37,111 @@ import Reflex.TriggerEvent.Class
3137
3238import Control.Monad.Exception
3339import Control.Monad.Identity
34−import Control.Monad.Primitive
3540import Control.Monad.Reader
3641import Control.Monad.Ref
3742import Control.Monad.State.Strict
43+import Data.Bits
3844import Data.Coerce
3945import Data.Dependent.Map (DMap, DSum (..))
4046import qualified Data.Dependent.Map as DMap
47+import qualified Data.Some as Some
48+import Data.Functor.Compose
4149import Data.Functor.Misc
50+import Data.Int
4251import Data.Map (Map)
52+import Data.Monoid
4353import Data.Unique.Tag
4454import Data.Some (Some)
55+import Data.Tuple
56+import Data.Type.Equality
57+
58+import Unsafe.Coerce
59+
60+newtype RequesterData f = RequesterData { unRequesterData :: DMap MyTag (Entry f) }
61+
62+-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
63+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
64+traverseRequesterData f (RequesterData m) = RequesterData <$> DMap.traverseWithKey go m --TODO: reverse
65+ where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
66+ go k (Entry request) = Entry <$> case myKeyType k of
67+ MyTagType_Single -> f request
68+ MyTagType_Multi -> traverseRequesterData f request
69+ MyTagType_Multi2 -> traverse (traverseRequesterData f) request
70+
71+data MyTagType :: * -> * where
72+ MyTagType_Single :: MyTagType (Single a)
73+ MyTagType_Multi :: MyTagType Multi
74+ MyTagType_Multi2 :: MyTagType (Multi2 k)
75+
76+myKeyType :: MyTag x -> MyTagType x
77+myKeyType (MyTag k) = case k .&. 0x3 of
78+ 0x0 -> unsafeCoerce MyTagType_Single
79+ 0x1 -> unsafeCoerce MyTagType_Multi
80+ 0x2 -> unsafeCoerce MyTagType_Multi2
81+ t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t
82+
83+data Single a
84+data Multi
85+data Multi2 (k :: * -> *)
86+
87+type family EntryContents request a where
88+ EntryContents request (Single a) = request a
89+ EntryContents request Multi = RequesterData request
90+ EntryContents request (Multi2 k) = Map (Some k) (RequesterData request)
91+
92+newtype Entry request x = Entry { unEntry :: EntryContents request x }
93+
94+{-# INLINE singleEntry #-}
95+singleEntry :: f a -> Entry f (Single a)
96+singleEntry = Entry
97+
98+{-# INLINE multiEntry #-}
99+multiEntry :: RequesterData f -> Entry f Multi
100+multiEntry = Entry
101+
102+-- | 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
103+-- 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
104+newtype MyTag x = MyTag Int32 deriving (Show, Eq, Ord, Enum)
105+
106+newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int32 deriving (Show, Eq, Ord, Enum)
107+
108+{-# INLINE castMyTagWrap #-}
109+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
110+castMyTagWrap = coerce
111+
112+instance GEq MyTag where
113+ (MyTag a) `geq` (MyTag b) =
114+ if a == b
115+ then Just $ unsafeCoerce Refl
116+ else Nothing
117+
118+instance GCompare MyTag where
119+ (MyTag a) `gcompare` (MyTag b) =
120+ case a `compare` b of
121+ LT -> GLT
122+ EQ -> unsafeCoerce GEQ
123+ GT -> GGT
124+
125+instance GEq (MyTagWrap f) where
126+ (MyTagWrap a) `geq` (MyTagWrap b) =
127+ if a == b
128+ then Just $ unsafeCoerce Refl
129+ else Nothing
130+
131+instance GCompare (MyTagWrap f) where
132+ (MyTagWrap a) `gcompare` (MyTagWrap b) =
133+ case a `compare` b of
134+ LT -> GLT
135+ EQ -> unsafeCoerce GEQ
136+ GT -> GGT
137+
138+data RequesterState t request = RequesterState
139+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int32 -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
140+ , _requesterState_requests :: ![DSum (MyTagWrap request) (Event t)]
141+ }
45142
46143-- | A basic implementation of 'Requester'.
47−newtype RequesterT t request response m a = RequesterT { unRequesterT :: EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }
144+newtype RequesterT t request response m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelector t (MyTagWrap response)) m) a }
48145 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
49146-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
50147#if MIN_VERSION_base(4,9,1)
@@ -57,6 +154,14 @@ deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
57154deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
58155deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
59156
157+{-# INLINE wrapMyTags #-}
158+wrapMyTags :: DMap MyTag (Entry f) -> DMap (MyTagWrap f) Identity
159+wrapMyTags = unsafeCoerce
160+
161+{-# INLINE unwrapMyTags #-}
162+unwrapMyTags :: DMap (MyTagWrap f) Identity -> DMap MyTag (Entry f)
163+unwrapMyTags = unsafeCoerce
164+
60165-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
61166-- requests are made, and responses should be provided in the input 'Event'.
62167-- The 'Tag' keys will be used to return the responses to the same place the
@@ -64,22 +169,36 @@ deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request respo
64169
65170runRequesterT :: (Reflex t, Monad m)
66171 => RequesterT t request response m a
67− -> Event t (DMap (Tag (PrimState m)) response)
68− -> m (a, Event t (DMap (Tag (PrimState m)) request))
172+ -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
173+ -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
69174runRequesterT (RequesterT a) responses = do
70− (result, requests) <- runReaderT (runEventWriterT a) $ fan $
71− mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses
72− return (result, requests)
175+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fan $
176+ fmapCheap (wrapMyTags . unRequesterData) responses
177+ return (result, fmapCheap (RequesterData . unwrapMyTags) $ merge $ DMap.fromDistinctAscList $ _requesterState_requests s)
73178
74−instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where
179+instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
75180 type Request (RequesterT t request response m) = request
76181 type Response (RequesterT t request response m) = response
77− withRequesting a = do
78− !t <- lift newTag --TODO: Fix this upstream
79− s <- RequesterT ask
80− (req, result) <- a $ select s $ WrapArg t
81− RequesterT $ tellEvent $ fmapCheap (DMap.singleton t) req
82− return result
182+ requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
183+ requesting_ = void . tagRequest . fmapCheap singleEntry
184+
185+{-# INLINE tagRequest #-}
186+tagRequest :: Monad m => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))
187+tagRequest req = do
188+ old <- RequesterT get
189+ let n = _requesterState_nextMyTag old
190+ t = MyTagWrap n
191+ RequesterT $ put $ RequesterState
192+ { _requesterState_nextMyTag = n - 0x4
193+ , _requesterState_requests = (t :=> req) : _requesterState_requests old
194+ }
195+ return t
196+
197+{-# INLINE responseFromTag #-}
198+responseFromTag :: (Monad m, Reflex t) => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
199+responseFromTag t = do
200+ responses :: EventSelector t (MyTagWrap response) <- RequesterT ask
201+ return $ select responses t
83202
84203instance MonadTrans (RequesterT t request response) where
85204 lift = RequesterT . lift . lift
@@ -101,34 +220,37 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT
101220
102221instance MonadReader r m => MonadReader r (RequesterT t request response m) where
103222 ask = lift ask
104− local f (RequesterT (EventWriterT a)) = RequesterT $ EventWriterT $ mapStateT (mapReaderT $ local f) a
223+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
105224 reader = lift . reader
106225
107−instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where
108− runWithReplace (RequesterT a) em = RequesterT $ runWithReplace a (coerceEvent em)
109− traverseDMapWithKeyWithAdjust f dm edm = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)
110− traverseDMapWithKeyWithAdjustWithMove f dm edm = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)
226+instance (Reflex t, MonadAdjust t m, MonadHold t m, MonadFix m) => MonadAdjust t (RequesterT t request response m) where
227+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
228+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
229+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
230+
231+requesting' :: (Monad m, Reflex t) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
232+requesting' = responseFromTag . castMyTagWrap <=< tagRequest
111233
112−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)
234+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
235+ , MonadFix m
236+ )
113237 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
114238 -> RequesterT t request response m a
115239 -> Event t (RequesterT t request response m b)
116240 -> RequesterT t request response m (a, Event t b)
117−runWithReplaceRequesterTWith f a0 a' =
118− let f' :: forall a' b'. ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m a'
119− -> Event t (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m b')
120− -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (a', Event t b')
121− f' x y = do
122− r <- EventWriterT $ ask
123− unRequesterT (f (runReaderT x r) (fmapCheap (`runReaderT` r) y))
124− in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')
125−
126−sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
241+runWithReplaceRequesterTWith f a0 a' = do
242+ rec response <- fmap (fmapCheap unEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
243+ ((result0, requests0), v') <- f (runRequesterT a0 response) $ fmapCheap (`runRequesterT` response) a'
244+ requests <- holdDyn requests0 $ fmapCheap snd v'
245+ return (result0, fmapCheap fst v')
246+
247+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
127248 ( GCompare k
128249 , Reflex t
129250 , MonadHold t m
130− , PatchTarget (p' (Some k) (Event t (DMap (Tag (PrimState m)) request))) ~ Map (Some k) (Event t (DMap (Tag (PrimState m)) request))
131− , Patch (p' (Some k) (Event t (DMap (Tag (PrimState m)) request)))
251+ , PatchTarget (p' (Some k) (Event t (RequesterData request))) ~ Map (Some k) (Event t (RequesterData request))
252+ , Patch (p' (Some k) (Event t (RequesterData request)))
253+ , MonadFix m
132254 )
133255 => (forall k' v1 v2. GCompare k'
134256 => (forall a. k' a -> v1 a -> m (v2 a))
@@ -138,19 +260,30 @@ sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
138260 )
139261 -> (forall v1. (forall a. v1 a -> v' a) -> p k v1 -> p k v')
140262 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
141− -> (forall v2. p' (Some k) v2 -> [v2])
263+ -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
142264 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
143265 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
144266 -> DMap k v
145267 -> Event t (p k v)
146268 -> RequesterT t request response m (DMap k v', Event t (p k v'))
147−sequenceDMapWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' =
148− let base' :: forall v1 v2.
149− (forall a. k a -> v1 a -> ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m (v2 a))
150− -> DMap k v1
151− -> Event t (p k v1)
152− -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (DMap k v2, Event t (p k v2))
153− base' f' x y = do
154− r <- EventWriterT ask
155− unRequesterT $ base (\k v -> runReaderT (f' k v) r) x y
156− in RequesterT $ sequenceDMapWithAdjustEventWriterTWith base' mapPatch weakenPatchWith patchNewElements mergePatchIncremental (\k v -> unRequesterT $ f k v) (coerce dm0) (coerceEvent dm')
269+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
270+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
271+ let responses :: EventSelector t (Const2 (Some k) (RequesterData response))
272+ responses = fanMap $ fmapCheap unpack response
273+ unpack :: Entry response (Multi2 k) -> Map (Some k) (RequesterData response)
274+ unpack = unEntry
275+ pack :: Map (Some k) (RequesterData request) -> Entry request (Multi2 k)
276+ pack = Entry
277+ f' :: forall a. k a -> v a -> m (Compose ((,) (Event t (RequesterData request))) v' a)
278+ f' k v = fmap (Compose . swap) $ runRequesterT (f k v) $ select responses (Const2 (Some.This k))
279+ (children0, children') <- base f' dm0 dm'
280+ let result0 = DMap.map (snd . getCompose) children0
281+ result' = fforCheap children' $ mapPatch $ snd . getCompose
282+ requests0 :: Map (Some k) (Event t (RequesterData request))
283+ requests0 = weakenDMapWith (fst . getCompose) children0
284+ requests' :: Event t (p' (Some k) (Event t (RequesterData request)))
285+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
286+ promptRequests :: Event t (Map (Some k) (RequesterData request))
287+ promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
288+ requests <- holdIncremental requests0 requests'
289+ return (result0, result')