git.iko.soy/reflex
on 02cf9db help sign in
reflex/src/Reflex/EventWriter.hs
167 lines 9.2 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 MonadTrans (EventWriterT t w) where
67 lift = EventWriterT . lift
69instance MonadSample t m => MonadSample t (EventWriterT t w m) where
70 sample = lift . sample
72instance MonadHold t m => MonadHold t (EventWriterT t w m) where
73 hold v0 = lift . hold v0
74 holdDyn v0 = lift . holdDyn v0
75 holdIncremental v0 = lift . holdIncremental v0
77instance (Reflex t, MonadAdjust t m, MonadHold t m, Monoid w, Semigroup w) => MonadAdjust t (EventWriterT t w m) where
78 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
79 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
80 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
82instance Requester t m => Requester t (EventWriterT t w m) where
83 type Request (EventWriterT t w m) = Request m
84 type Response (EventWriterT t w m) = Response m
85 withRequesting f = EventWriterT $ withRequesting $ unEventWriterT . f
88-- | Given a function like 'runWithReplace' for the underlying monad, implement
89-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
90-- monad doesn't have a 'MonadAdjust' instance or to override the default
91-- 'MonadAdjust' behavior.
92runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Monoid w)
93 => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
94 -> EventWriterT t w m a
95 -> Event t (EventWriterT t w m b)
96 -> EventWriterT t w m (a, Event t b)
97runWithReplaceEventWriterTWith f a0 a' = do
98 let g :: EventWriterT t w m c -> m (c, Seq (Event t w))
99 g (EventWriterT r) = runStateT r mempty
100 (result0, result') <- f (g a0) $ fmap g a'
101 request <- holdDyn (fmapCheap (mconcat . NonEmpty.toList) $ mergeList $ toList $ snd result0) $ fmapCheap (fmapCheap (mconcat . NonEmpty.toList) . mergeList . toList . snd) result'
102 -- 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.)
103 EventWriterT $ modify $ flip (|>) $ coincidence $ updated request
104 EventWriterT $ modify $ flip (|>) $ switch $ current request
105 return (fst result0, fmapCheap fst result')
107-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
108sequenceDMapWithAdjustEventWriterTWith :: 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))
109 => ( (forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a))
110 -> DMap k v
111 -> Event t (p k v)
112 -> EventWriterT t w m (DMap k (Compose ((,) (Seq (Event t w))) v'), Event t (p k (Compose ((,) (Seq (Event t w))) v')))
113 )
114 -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> v' a) -> p k (Compose ((,) (Seq (Event t w))) v') -> p k v')
115 -> ((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))
116 -> (p' (Some k) (Event t w) -> [Event t w])
117 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
118 -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
119 -> DMap k v
120 -> Event t (p k v)
121 -> EventWriterT t w m (DMap k v', Event t (p k v'))
122sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
123 let f' :: forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a)
124 f' k v = Compose . swap <$> runStateT (unEventWriterT $ f k v) mempty
125 (children0, children') <- base f' dm0 dm'
126 let result0 = DMap.map (snd . getCompose) children0
127 result' = fforCheap children' $ mapPatch $ snd . getCompose
128 requests0 :: Map (Some k) (Event t w)
129 requests0 = weakenDMapWith (mconcat . toList . fst . getCompose) children0
130 requests' :: Event t (p' (Some k) (Event t w))
131 requests' = fforCheap children' $ weakenPatchWith $ mconcat . toList . fst . getCompose
132 childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
133 -- 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.)
134 EventWriterT $ modify $ flip (|>) $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
135 EventWriterT $ modify $ flip (|>) $ fold <$> mergePatchIncremental childRequestMap
136 return (result0, result')
138instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
139 type Performable (EventWriterT t w m) = Performable m
140 performEvent_ = lift . performEvent_
141 performEvent = lift . performEvent
143instance PostBuild t m => PostBuild t (EventWriterT t w m) where
144 getPostBuild = lift getPostBuild
146instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
147 newTriggerEvent = lift newTriggerEvent
148 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
149 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
151instance MonadReader r m => MonadReader r (EventWriterT t w m) where
152 ask = lift ask
153 local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
154 reader = lift . reader
156instance MonadRef m => MonadRef (EventWriterT t w m) where
157 type Ref (EventWriterT t w m) = Ref m
158 newRef = lift . newRef
159 readRef = lift . readRef
160 writeRef r = lift . writeRef r
162instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
163 atomicModifyRef r = lift . atomicModifyRef r
165instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
166 newEventWithTrigger = lift . newEventWithTrigger
167 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f