git.iko.soy/patch
on 4c9d756 help sign in
patch/src/Reflex/Requester/Base.hs
133 lines 6.8 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.Unique.Tag
43-- | A basic implementation of 'Requester'.
44newtype 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 }
45 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
47deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
48deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
49deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
50deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
52-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
53-- requests are made, and responses should be provided in the input 'Event'.
54-- The 'Tag' keys will be used to return the responses to the same place the
55-- requests were issued.
57runRequesterT :: (Reflex t, Monad m)
58 => RequesterT t request response m a
59 -> Event t (DMap (Tag (PrimState m)) response)
60 -> m (a, Event t (DMap (Tag (PrimState m)) request))
61runRequesterT (RequesterT a) responses = do
62 (result, requests) <- runReaderT (runEventWriterT a) $ fan $
63 mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses
64 return (result, requests)
66instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where
67 type Request (RequesterT t request response m) = request
68 type Response (RequesterT t request response m) = response
69 withRequesting a = do
70 t <- lift newTag
71 s <- RequesterT ask
72 (req, result) <- a $ select s $ WrapArg t
73 RequesterT $ tellEvent $ DMap.singleton t <$> req
74 return result
76instance MonadTrans (RequesterT t request response) where
77 lift = RequesterT . lift . lift
79instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
80 type Performable (RequesterT t request response m) = Performable m
81 performEvent_ = lift . performEvent_
82 performEvent = lift . performEvent
84instance MonadRef m => MonadRef (RequesterT t request response m) where
85 type Ref (RequesterT t request response m) = Ref m
86 newRef = lift . newRef
87 readRef = lift . readRef
88 writeRef r = lift . writeRef r
90instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
91 newEventWithTrigger = lift . newEventWithTrigger
92 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
94instance MonadReader r m => MonadReader r (RequesterT t request response m) where
95 ask = lift ask
96 local f (RequesterT (EventWriterT a)) = RequesterT $ EventWriterT $ mapStateT (mapReaderT $ local f) a
97 reader = lift . reader
99instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where
100 runWithReplace (RequesterT a) em = RequesterT $ runWithReplace a (coerceEvent em)
101 sequenceDMapWithAdjust dm edm = RequesterT $ sequenceDMapWithAdjust (coerce dm) (coerceEvent edm)
103runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)
104 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
105 -> RequesterT t request response m a
106 -> Event t (RequesterT t request response m b)
107 -> RequesterT t request response m (a, Event t b)
108runWithReplaceRequesterTWith f a0 a' =
109 let f' :: forall a' b'. ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m a'
110 -> Event t (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m b')
111 -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (a', Event t b')
112 f' x y = do
113 r <- EventWriterT $ ask
114 unRequesterT (f (runReaderT x r) (fmap (`runReaderT` r) y))
115 in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')
117sequenceDMapWithAdjustRequesterTWith :: (GCompare k, Reflex t, MonadHold t m)
118 => (forall k'. GCompare k' => DMap k' m -> Event t (PatchDMap k' m) -> RequesterT t request response m (DMap k' Identity, Event t (PatchDMap k' Identity)))
119 -> DMap k (RequesterT t request response m)
120 -> Event t (PatchDMap k (RequesterT t request response m))
121 -> RequesterT t request response m (DMap k Identity, Event t (PatchDMap k Identity))
122sequenceDMapWithAdjustRequesterTWith f (dm0 :: DMap k (RequesterT t request response m)) dm' =
123 let dmapUnwrap r = mapKeyValuePairsMonotonic $ \(k :=> v) -> k :=> runReaderT v r
124 patchDmapUnwrap r (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic
125 (\(k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (`runReaderT` r) mv)) p
126 f' :: forall k'. GCompare k'
127 => DMap k' (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m)
128 -> Event t (PatchDMap k' (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m))
129 -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (DMap k' Identity, Event t (PatchDMap k' Identity))
130 f' x y = do
131 r <- EventWriterT $ ask
132 unRequesterT (f (dmapUnwrap r x) (fmap (patchDmapUnwrap r) y))
133 in RequesterT $ sequenceDMapWithAdjustEventWriterTWith f' (coerce dm0) (coerceEvent dm')