git.iko.soy/patch
on 9fe075a help sign in
patch/src/Reflex/EventWriter.hs
169 lines 9.0 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 KindSignatures #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE Rank2Types #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE UndecidableInstances #-}
14#ifdef USE_REFLEX_OPTIMIZER
15{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16#endif
17module Reflex.EventWriter
18 ( EventWriterT (..)
19 , runEventWriterT
20 , EventWriter(..)
21 , runWithReplaceEventWriterTWith
22 , sequenceDMapWithAdjustEventWriterTWith
23 ) where
25import Reflex.Class
26import Reflex.Host.Class
27import Reflex.PerformEvent.Class
28import Reflex.PostBuild.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, DSum (..))
37import qualified Data.Dependent.Map as DMap
38import Data.Foldable
39import Data.Functor.Misc
40import qualified Data.List.NonEmpty as NonEmpty
41import Data.Maybe
42import Data.Semigroup
43import Data.Sequence
44import Data.Some (Some)
45import qualified Data.Some as Some
46import Data.Tuple
47import Data.Unique.Tag
49-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
50-- and combines them monoidally to provide an 'Event' result.
51class (Monad m, Monoid 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)
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, Monoid w) => EventWriter t w (EventWriterT t w m) where
65 tellEvent w = EventWriterT $ modify (|> w)
67instance MonadTrans (EventWriterT t w) where
68 lift = EventWriterT . lift
70instance MonadSample t m => MonadSample t (EventWriterT t w m) where
71 sample = lift . sample
73instance MonadHold t m => MonadHold t (EventWriterT t w m) where
74 hold v0 = lift . hold v0
75 holdDyn v0 = lift . holdDyn v0
76 holdIncremental v0 = lift . holdIncremental v0
78instance (Reflex t, MonadAdjust t m, MonadHold t m, Monoid w, Semigroup w) => MonadAdjust t (EventWriterT t w m) where
79 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
80 sequenceDMapWithAdjust = sequenceDMapWithAdjustEventWriterTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'
82-- | Given a function like 'runWithReplace' for the underlying monad, implement
83-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
84-- monad doesn't have a 'MonadAdjust' instance or to override the default
85-- 'MonadAdjust' behavior.
86runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Monoid w)
87 => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
88 -> EventWriterT t w m a
89 -> Event t (EventWriterT t w m b)
90 -> EventWriterT t w m (a, Event t b)
91runWithReplaceEventWriterTWith f a0 a' = do
92 let g :: EventWriterT t w m c -> m (c, Seq (Event t w))
93 g (EventWriterT r) = runStateT r mempty
94 (result0, result') <- f (g a0) $ g <$> a'
95 request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ toList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . toList . snd <$> result'
96 -- 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.)
97 EventWriterT $ modify $ flip (|>) $ coincidence $ updated request
98 EventWriterT $ modify $ flip (|>) $ switch $ current request
99 return (fst result0, fst <$> result')
101-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
102sequenceDMapWithAdjustEventWriterTWith :: (GCompare k, Reflex t, MonadHold t m, Monoid w, Semigroup w)
103 => (forall k'. GCompare k'
104 => DMap k' m
105 -> Event t (PatchDMap k' m)
106 -> EventWriterT t w m (DMap k' Identity, Event t (PatchDMap k' Identity))
107 )
108 -> DMap k (EventWriterT t w m)
109 -> Event t (PatchDMap k (EventWriterT t w m))
110 -> EventWriterT t w m (DMap k Identity, Event t (PatchDMap k Identity))
111sequenceDMapWithAdjustEventWriterTWith f (dm0 :: DMap k (EventWriterT t w m)) dm' = do
112 let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) (Seq (Event t w))) k) (EventWriterT t w m) m
113 inputTransform = DMapTransform WrapArg (\(EventWriterT v) -> swap <$> runStateT v mempty)
114 (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'
115 let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
116 result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
117 mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Identity . snd . runIdentity) mv)) p
118 requests0 :: DMap (Const2 (Some k) w) (Event t)
119 requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mconcat (toList r)) children0
120 requests' :: Event t (PatchDMap (Const2 (Some k) w) (Event t))
121 requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $
122 mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mconcat . toList . fst . runIdentity) mv)) p
123 childRequestMap <- holdIncremental requests0 requests'
124 -- 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.)
125 EventWriterT $ modify $ flip (|>) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mconcat $ toList $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me
126 EventWriterT $ modify $ flip (|>) $ ffor (mergeIncremental childRequestMap) $ \m ->
127 mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m
128 return (result0, result')
130instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
131 type Performable (EventWriterT t w m) = Performable m
132 performEvent_ = lift . performEvent_
133 performEvent = lift . performEvent
135instance PostBuild t m => PostBuild t (EventWriterT t w m) where
136 getPostBuild = lift getPostBuild
138instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
139 newTriggerEvent = lift newTriggerEvent
140 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
141 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
143instance MonadReader r m => MonadReader r (EventWriterT t w m) where
144 ask = lift ask
145 local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
146 reader = lift . reader
148instance MonadRef m => MonadRef (EventWriterT t w m) where
149 type Ref (EventWriterT t w m) = Ref m
150 newRef = lift . newRef
151 readRef = lift . readRef
152 writeRef r = lift . writeRef r
154instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
155 newEventWithTrigger = lift . newEventWithTrigger
156 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
158--------------------------------------------------------------------------------
159-- Internal functions
160--------------------------------------------------------------------------------
162data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)
164mapPatchKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> PatchDMap k v -> PatchDMap k' v'
165mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> case x of DMapTransform f g -> f k :=> ComposeMaybe (fmap g mv)) p
167mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'
168mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of
169 DMapTransform f g -> f k :=> g v