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