git.iko.soy/patch
on ef4da28 help sign in
patch/src/Reflex/Requester/Base.hs
156 lines 8.2 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
49-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
50#if MIN_VERSION_base(4,9,1)
51 , MonadAsyncException
52#endif
53 )
55deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
56deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
57deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
58deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
60-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
61-- requests are made, and responses should be provided in the input 'Event'.
62-- The 'Tag' keys will be used to return the responses to the same place the
63-- requests were issued.
65runRequesterT :: (Reflex t, Monad m)
66 => RequesterT t request response m a
67 -> Event t (DMap (Tag (PrimState m)) response)
68 -> m (a, Event t (DMap (Tag (PrimState m)) request))
69runRequesterT (RequesterT a) responses = do
70 (result, requests) <- runReaderT (runEventWriterT a) $ fan $
71 mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses
72 return (result, requests)
74instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where
75 type Request (RequesterT t request response m) = request
76 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
84instance MonadTrans (RequesterT t request response) where
85 lift = RequesterT . lift . lift
87instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
88 type Performable (RequesterT t request response m) = Performable m
89 performEvent_ = lift . performEvent_
90 performEvent = lift . performEvent
92instance MonadRef m => MonadRef (RequesterT t request response m) where
93 type Ref (RequesterT t request response m) = Ref m
94 newRef = lift . newRef
95 readRef = lift . readRef
96 writeRef r = lift . writeRef r
98instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
99 newEventWithTrigger = lift . newEventWithTrigger
100 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
102instance MonadReader r m => MonadReader r (RequesterT t request response m) where
103 ask = lift ask
104 local f (RequesterT (EventWriterT a)) = RequesterT $ EventWriterT $ mapStateT (mapReaderT $ local f) a
105 reader = lift . reader
107instance (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)
112runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)
113 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
114 -> RequesterT t request response m a
115 -> Event t (RequesterT t request response m b)
116 -> RequesterT t request response m (a, Event t b)
117runWithReplaceRequesterTWith 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')
126sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
127 ( GCompare k
128 , Reflex t
129 , 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)))
132 )
133 => (forall k' v1 v2. GCompare k'
134 => (forall a. k' a -> v1 a -> m (v2 a))
135 -> DMap k' v1
136 -> Event t (p k' v1)
137 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
138 )
139 -> (forall v1. (forall a. v1 a -> v' a) -> p k v1 -> p k v')
140 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
141 -> (forall v2. p' (Some k) v2 -> [v2])
142 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
143 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
144 -> DMap k v
145 -> Event t (p k v)
146 -> RequesterT t request response m (DMap k v', Event t (p k v'))
147sequenceDMapWithAdjustRequesterTWith 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')