git.iko.soy/patch
on 12e83ae help sign in
patch/src/Reflex/EventWriter.hs
178 lines 9.6 kB history raw
1-- | This module provides 'EventWriterT', the standard implementation of
2-- 'EventWriter'.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FunctionalDependencies #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
13#ifdef USE_REFLEX_OPTIMIZER
14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15#endif
16module Reflex.EventWriter
17 ( EventWriterT (..)
18 , runEventWriterT
19 , EventWriter (..)
20 , runWithReplaceEventWriterTWith
21 , sequenceDMapWithAdjustEventWriterTWith
22 ) where
24import Reflex.Class
25import Reflex.Host.Class
26import Reflex.PerformEvent.Class
27import Reflex.PostBuild.Class
28import Reflex.Query.Class
29import Reflex.Requester.Class
30import Reflex.TriggerEvent.Class
32import Control.Monad.Exception
33import Control.Monad.Identity
34import Control.Monad.Reader
35import Control.Monad.Ref
36import Control.Monad.State.Strict
37import Data.Dependent.Map (DMap)
38import qualified Data.Dependent.Map as DMap
39import Data.Foldable
40import Data.Functor.Compose
41import Data.Functor.Misc
42import Data.List.NonEmpty (NonEmpty (..))
43import Data.Map (Map)
44import Data.Semigroup
45import Data.Sequence
46import Data.Some (Some)
47import Data.Tuple
49-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
50-- and combines them monoidally to provide an 'Event' result.
51class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
52 tellEvent :: Event t w -> m ()
54-- | A basic implementation of 'EventWriter'.
55newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (Seq (Event t w)) m a }
56 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
58-- | Run a 'EventWriterT' action.
59runEventWriterT :: (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
60runEventWriterT (EventWriterT a) = do
61 (result, requests) <- runStateT a mempty
62 return (result, mconcat $ toList requests)
64instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
65 tellEvent w = EventWriterT $ modify (|> w)
67instance EventWriter t w m => EventWriter t w (ReaderT r m) where
68 tellEvent = lift . tellEvent
70instance MonadTrans (EventWriterT t w) where
71 lift = EventWriterT . lift
73instance MonadSample t m => MonadSample t (EventWriterT t w m) where
74 sample = lift . sample
76instance MonadHold t m => MonadHold t (EventWriterT t w m) where
77 hold v0 = lift . hold v0
78 holdDyn v0 = lift . holdDyn v0
79 holdIncremental v0 = lift . holdIncremental v0
81instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w) => MonadAdjust t (EventWriterT t w m) where
82 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
83 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
84 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
86instance Requester t m => Requester t (EventWriterT t w m) where
87 type Request (EventWriterT t w m) = Request m
88 type Response (EventWriterT t w m) = Response m
89 withRequesting f = EventWriterT $ withRequesting $ unEventWriterT . f
92-- | Given a function like 'runWithReplace' for the underlying monad, implement
93-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
94-- monad doesn't have a 'MonadAdjust' instance or to override the default
95-- 'MonadAdjust' behavior.
96runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)
97 => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
98 -> EventWriterT t w m a
99 -> Event t (EventWriterT t w m b)
100 -> EventWriterT t w m (a, Event t b)
101runWithReplaceEventWriterTWith f a0 a' = do
102 let g :: EventWriterT t w m c -> m (c, Seq (Event t w))
103 g (EventWriterT r) = runStateT r mempty
104 (result0, result') <- f (g a0) $ fmap g a'
105 request <- holdDyn (fmapCheap sconcat $ mergeList $ toList $ snd result0) $ fmapCheap (fmapCheap sconcat . mergeList . toList . snd) result'
106 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
107 EventWriterT $ modify $ flip (|>) $ coincidence $ updated request
108 EventWriterT $ modify $ flip (|>) $ switch $ current request
109 return (fst result0, fmapCheap fst result')
111-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
112sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))
113 => ( (forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a))
114 -> DMap k v
115 -> Event t (p k v)
116 -> EventWriterT t w m (DMap k (Compose ((,) (Seq (Event t w))) v'), Event t (p k (Compose ((,) (Seq (Event t w))) v')))
117 )
118 -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> v' a) -> p k (Compose ((,) (Seq (Event t w))) v') -> p k v')
119 -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> Event t w) -> p k (Compose ((,) (Seq (Event t w))) v') -> p' (Some k) (Event t w))
120 -> (p' (Some k) (Event t w) -> [Event t w])
121 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
122 -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
123 -> DMap k v
124 -> Event t (p k v)
125 -> EventWriterT t w m (DMap k v', Event t (p k v'))
126sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
127 let f' :: forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a)
128 f' k v = Compose . swap <$> runStateT (unEventWriterT $ f k v) mempty
129 (children0, children') <- base f' dm0 dm'
130 let result0 = DMap.map (snd . getCompose) children0
131 result' = fforCheap children' $ mapPatch $ snd . getCompose
132 requests0 :: Map (Some k) (Event t w)
133 requests0 = weakenDMapWith (mconcat . toList . fst . getCompose) children0
134 requests' :: Event t (p' (Some k) (Event t w))
135 requests' = fforCheap children' $ weakenPatchWith $ mconcat . toList . fst . getCompose
136 childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
137 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
138 EventWriterT $ modify $ flip (|>) $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
139 EventWriterT $ modify $ flip (|>) $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
140 [] -> Nothing
141 h : t -> Just $ sconcat $ h :| t
142 return (result0, result')
144instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
145 type Performable (EventWriterT t w m) = Performable m
146 performEvent_ = lift . performEvent_
147 performEvent = lift . performEvent
149instance PostBuild t m => PostBuild t (EventWriterT t w m) where
150 getPostBuild = lift getPostBuild
152instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
153 newTriggerEvent = lift newTriggerEvent
154 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
155 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
157instance MonadReader r m => MonadReader r (EventWriterT t w m) where
158 ask = lift ask
159 local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
160 reader = lift . reader
162instance MonadRef m => MonadRef (EventWriterT t w m) where
163 type Ref (EventWriterT t w m) = Ref m
164 newRef = lift . newRef
165 readRef = lift . readRef
166 writeRef r = lift . writeRef r
168instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
169 atomicModifyRef r = lift . atomicModifyRef r
171instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
172 newEventWithTrigger = lift . newEventWithTrigger
173 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
175instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where
176 tellQueryIncremental = lift . tellQueryIncremental
177 askQueryResult = lift askQueryResult
178 queryIncremental = lift . queryIncremental