git.iko.soy/patch
on ae0af76 help sign in
patch/src/Reflex/EventWriter.hs
170 lines 9.3 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.Requester.Class
29import Reflex.TriggerEvent.Class
31import Control.Monad.Exception
32import Control.Monad.Identity
33import Control.Monad.Reader
34import Control.Monad.Ref
35import Control.Monad.State.Strict
36import Data.Dependent.Map (DMap)
37import qualified Data.Dependent.Map as DMap
38import Data.Foldable
39import Data.Functor.Compose
40import Data.Functor.Misc
41import qualified Data.List.NonEmpty as NonEmpty
42import Data.Map (Map)
43import Data.Semigroup
44import Data.Sequence
45import Data.Some (Some)
46import Data.Tuple
48-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
49-- and combines them monoidally to provide an 'Event' result.
50class (Monad m, Monoid w) => EventWriter t w m | m -> t w where
51 tellEvent :: Event t w -> m ()
53-- | A basic implementation of 'EventWriter'.
54newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (Seq (Event t w)) m a }
55 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
57-- | Run a 'EventWriterT' action.
58runEventWriterT :: (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
59runEventWriterT (EventWriterT a) = do
60 (result, requests) <- runStateT a mempty
61 return (result, mconcat $ toList requests)
63instance (Reflex t, Monad m, Monoid w) => EventWriter t w (EventWriterT t w m) where
64 tellEvent w = EventWriterT $ modify (|> w)
66instance EventWriter t w m => EventWriter t w (ReaderT r m) where
67 tellEvent = lift . tellEvent
69instance MonadTrans (EventWriterT t w) where
70 lift = EventWriterT . lift
72instance MonadSample t m => MonadSample t (EventWriterT t w m) where
73 sample = lift . sample
75instance MonadHold t m => MonadHold t (EventWriterT t w m) where
76 hold v0 = lift . hold v0
77 holdDyn v0 = lift . holdDyn v0
78 holdIncremental v0 = lift . holdIncremental v0
80instance (Reflex t, MonadAdjust t m, MonadHold t m, Monoid w, Semigroup w) => MonadAdjust t (EventWriterT t w m) where
81 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
82 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
83 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
85instance Requester t m => Requester t (EventWriterT t w m) where
86 type Request (EventWriterT t w m) = Request m
87 type Response (EventWriterT t w m) = Response m
88 withRequesting f = EventWriterT $ withRequesting $ unEventWriterT . f
91-- | Given a function like 'runWithReplace' for the underlying monad, implement
92-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
93-- monad doesn't have a 'MonadAdjust' instance or to override the default
94-- 'MonadAdjust' behavior.
95runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Monoid w)
96 => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
97 -> EventWriterT t w m a
98 -> Event t (EventWriterT t w m b)
99 -> EventWriterT t w m (a, Event t b)
100runWithReplaceEventWriterTWith f a0 a' = do
101 let g :: EventWriterT t w m c -> m (c, Seq (Event t w))
102 g (EventWriterT r) = runStateT r mempty
103 (result0, result') <- f (g a0) $ fmap g a'
104 request <- holdDyn (fmapCheap (mconcat . NonEmpty.toList) $ mergeList $ toList $ snd result0) $ fmapCheap (fmapCheap (mconcat . NonEmpty.toList) . mergeList . toList . snd) result'
105 -- 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.)
106 EventWriterT $ modify $ flip (|>) $ coincidence $ updated request
107 EventWriterT $ modify $ flip (|>) $ switch $ current request
108 return (fst result0, fmapCheap fst result')
110-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
111sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Monoid w, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))
112 => ( (forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a))
113 -> DMap k v
114 -> Event t (p k v)
115 -> EventWriterT t w m (DMap k (Compose ((,) (Seq (Event t w))) v'), Event t (p k (Compose ((,) (Seq (Event t w))) v')))
116 )
117 -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> v' a) -> p k (Compose ((,) (Seq (Event t w))) v') -> p k v')
118 -> ((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))
119 -> (p' (Some k) (Event t w) -> [Event t w])
120 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
121 -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
122 -> DMap k v
123 -> Event t (p k v)
124 -> EventWriterT t w m (DMap k v', Event t (p k v'))
125sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
126 let f' :: forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a)
127 f' k v = Compose . swap <$> runStateT (unEventWriterT $ f k v) mempty
128 (children0, children') <- base f' dm0 dm'
129 let result0 = DMap.map (snd . getCompose) children0
130 result' = fforCheap children' $ mapPatch $ snd . getCompose
131 requests0 :: Map (Some k) (Event t w)
132 requests0 = weakenDMapWith (mconcat . toList . fst . getCompose) children0
133 requests' :: Event t (p' (Some k) (Event t w))
134 requests' = fforCheap children' $ weakenPatchWith $ mconcat . toList . fst . getCompose
135 childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
136 -- 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.)
137 EventWriterT $ modify $ flip (|>) $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
138 EventWriterT $ modify $ flip (|>) $ fold <$> mergePatchIncremental childRequestMap
139 return (result0, result')
141instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
142 type Performable (EventWriterT t w m) = Performable m
143 performEvent_ = lift . performEvent_
144 performEvent = lift . performEvent
146instance PostBuild t m => PostBuild t (EventWriterT t w m) where
147 getPostBuild = lift getPostBuild
149instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
150 newTriggerEvent = lift newTriggerEvent
151 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
152 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
154instance MonadReader r m => MonadReader r (EventWriterT t w m) where
155 ask = lift ask
156 local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
157 reader = lift . reader
159instance MonadRef m => MonadRef (EventWriterT t w m) where
160 type Ref (EventWriterT t w m) = Ref m
161 newRef = lift . newRef
162 readRef = lift . readRef
163 writeRef r = lift . writeRef r
165instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
166 atomicModifyRef r = lift . atomicModifyRef r
168instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
169 newEventWithTrigger = lift . newEventWithTrigger
170 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f