git.iko.soy/reflex
on 02cf9db help sign in
reflex/src/Reflex/Requester/Base.hs
150 lines 8.0 kB history raw
1-- | This module provides 'RequesterT', the standard implementation of
2-- 'Requester'.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE Rank2Types #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE StandaloneDeriving #-}
13#ifdef USE_REFLEX_OPTIMIZER
14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15#endif
16module Reflex.Requester.Base
17 ( RequesterT (..)
18 , runRequesterT
19 , runWithReplaceRequesterTWith
20 , sequenceDMapWithAdjustRequesterTWith
21 ) where
23import Reflex.Class
24import Reflex.EventWriter
25import Reflex.Host.Class
26import Reflex.PerformEvent.Class
27import Reflex.PostBuild.Class
28import Reflex.Requester.Class
29import Reflex.TriggerEvent.Class
31import Control.Monad.Exception
32import Control.Monad.Identity
33import Control.Monad.Primitive
34import Control.Monad.Reader
35import Control.Monad.Ref
36import Control.Monad.State.Strict
37import Data.Coerce
38import Data.Dependent.Map (DMap, DSum (..))
39import qualified Data.Dependent.Map as DMap
40import Data.Functor.Misc
41import Data.Map (Map)
42import Data.Unique.Tag
43import Data.Some (Some)
45-- | A basic implementation of 'Requester'.
46newtype 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 }
47 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
49deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
50deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
51deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
52deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
54-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
55-- requests are made, and responses should be provided in the input 'Event'.
56-- The 'Tag' keys will be used to return the responses to the same place the
57-- requests were issued.
59runRequesterT :: (Reflex t, Monad m)
60 => RequesterT t request response m a
61 -> Event t (DMap (Tag (PrimState m)) response)
62 -> m (a, Event t (DMap (Tag (PrimState m)) request))
63runRequesterT (RequesterT a) responses = do
64 (result, requests) <- runReaderT (runEventWriterT a) $ fan $
65 mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses
66 return (result, requests)
68instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where
69 type Request (RequesterT t request response m) = request
70 type Response (RequesterT t request response m) = response
71 withRequesting a = do
72 t <- lift newTag
73 s <- RequesterT ask
74 (req, result) <- a $ select s $ WrapArg t
75 RequesterT $ tellEvent $ fmapCheap (DMap.singleton t) req
76 return result
78instance MonadTrans (RequesterT t request response) where
79 lift = RequesterT . lift . lift
81instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
82 type Performable (RequesterT t request response m) = Performable m
83 performEvent_ = lift . performEvent_
84 performEvent = lift . performEvent
86instance MonadRef m => MonadRef (RequesterT t request response m) where
87 type Ref (RequesterT t request response m) = Ref m
88 newRef = lift . newRef
89 readRef = lift . readRef
90 writeRef r = lift . writeRef r
92instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
93 newEventWithTrigger = lift . newEventWithTrigger
94 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
96instance MonadReader r m => MonadReader r (RequesterT t request response m) where
97 ask = lift ask
98 local f (RequesterT (EventWriterT a)) = RequesterT $ EventWriterT $ mapStateT (mapReaderT $ local f) a
99 reader = lift . reader
101instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where
102 runWithReplace (RequesterT a) em = RequesterT $ runWithReplace a (coerceEvent em)
103 traverseDMapWithKeyWithAdjust f dm edm = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)
104 traverseDMapWithKeyWithAdjustWithMove f dm edm = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)
106runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)
107 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
108 -> RequesterT t request response m a
109 -> Event t (RequesterT t request response m b)
110 -> RequesterT t request response m (a, Event t b)
111runWithReplaceRequesterTWith f a0 a' =
112 let f' :: forall a' b'. ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m a'
113 -> Event t (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m b')
114 -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (a', Event t b')
115 f' x y = do
116 r <- EventWriterT $ ask
117 unRequesterT (f (runReaderT x r) (fmapCheap (`runReaderT` r) y))
118 in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')
120sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
121 ( GCompare k
122 , Reflex t
123 , MonadHold t m
124 , PatchTarget (p' (Some k) (Event t (DMap (Tag (PrimState m)) request))) ~ Map (Some k) (Event t (DMap (Tag (PrimState m)) request))
125 , Patch (p' (Some k) (Event t (DMap (Tag (PrimState m)) request)))
126 )
127 => (forall k' v1 v2. GCompare k'
128 => (forall a. k' a -> v1 a -> m (v2 a))
129 -> DMap k' v1
130 -> Event t (p k' v1)
131 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
132 )
133 -> (forall v1. (forall a. v1 a -> v' a) -> p k v1 -> p k v')
134 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
135 -> (forall v2. p' (Some k) v2 -> [v2])
136 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
137 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
138 -> DMap k v
139 -> Event t (p k v)
140 -> RequesterT t request response m (DMap k v', Event t (p k v'))
141sequenceDMapWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' =
142 let base' :: forall v1 v2.
143 (forall a. k a -> v1 a -> ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m (v2 a))
144 -> DMap k v1
145 -> Event t (p k v1)
146 -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (DMap k v2, Event t (p k v2))
147 base' f' x y = do
148 r <- EventWriterT ask
149 unRequesterT $ base (\k v -> runReaderT (f' k v) r) x y
150 in RequesterT $ sequenceDMapWithAdjustEventWriterTWith base' mapPatch weakenPatchWith patchNewElements mergePatchIncremental (\k v -> unRequesterT $ f k v) (coerce dm0) (coerceEvent dm')