@@ -0,0 +1,172 @@
1+-- | This module provides 'EventWriterT', the standard implementation of
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 #-}
17+module Reflex.EventWriter
24+import Reflex.Host.Class
25+import Reflex.PerformEvent.Class
26+import Reflex.PostBuild.Class
27+import Reflex.TriggerEvent.Class
29+import Control.Monad.Exception
30+import Control.Monad.Identity
31+import Control.Monad.Reader
32+import Control.Monad.Ref
33+import Control.Monad.State.Strict
34+import Data.Dependent.Map (DMap, DSum (..))
35+import qualified Data.Dependent.Map as DMap
36+import Data.Functor.Misc
37+import qualified Data.List.NonEmpty as NonEmpty
40+import Data.Some (Some)
41+import qualified Data.Some as Some
43+import Data.Unique.Tag
45+-- | 'MonadEventWriter' efficiently collects 'Event' values using 'tellEvent'
46+-- and combines them monoidally to provide an 'Event' result.
47+class (Monad m, Monoid w) => EventWriter t w m | m -> t w where
48+ tellEvent :: Event t w -> m ()
50+-- | A basic implementation of 'EventWriter'.
51+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT [Event t w] m a }
52+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
54+-- | Run a 'EventWriterT' action.
56+ :: (Reflex t, Monad m, Semigroup w)
57+ => EventWriterT t w m a
59+runEventWriterT (EventWriterT a) = do
60+ (result, requests) <- runStateT a mempty
61+ return (result, mconcat $ reverse requests)
63+instance (Reflex t, Monad m, Monoid w) => EventWriter t w (EventWriterT t w m) where
64+ tellEvent w = EventWriterT $ modify (w:)
66+instance MonadTrans (EventWriterT t w) where
67+ lift = EventWriterT . lift
69+instance MonadSample t m => MonadSample t (EventWriterT t w m) where
70+ sample = lift . sample
72+instance 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
77+instance (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+ sequenceDMapWithAdjust = sequenceDMapWithAdjustEventWriterTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'
81+-- | Given a function like 'runWithReplace' for the underlying monad, implement
82+-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
83+-- monad doesn't have a 'MonadAdjust' instance or to override the default
84+-- 'MonadAdjust' behavior.
85+runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Monoid w)
89+ -> EventWriterT t w m (a', Event t b')
91+ -> EventWriterT t w m a
92+ -> Event t (EventWriterT t w m b)
93+ -> EventWriterT t w m (a, Event t b)
94+runWithReplaceEventWriterTWith f a0 a' = do
95+ let g :: EventWriterT t w m c -> m (c, [Event t w])
96+ g (EventWriterT r) = runStateT r mempty
97+ (result0, result') <- f (g a0) $ g <$> a'
98+ request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . snd <$> result'
99+ -- 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.)
100+ EventWriterT $ modify $ (:) $ coincidence $ updated request
101+ EventWriterT $ modify $ (:) $ switch $ current request
102+ return (fst result0, fst <$> result')
104+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
105+sequenceDMapWithAdjustEventWriterTWith :: (GCompare k, Reflex t, MonadHold t m, Monoid w, Semigroup w)
106+ => (forall k'. GCompare k'
108+ -> Event t (PatchDMap k' m)
109+ -> EventWriterT t w m (DMap k' Identity, Event t (PatchDMap k' Identity))
111+ -> DMap k (EventWriterT t w m)
112+ -> Event t (PatchDMap k (EventWriterT t w m))
113+ -> EventWriterT t w m (DMap k Identity, Event t (PatchDMap k Identity))
114+sequenceDMapWithAdjustEventWriterTWith f (dm0 :: DMap k (EventWriterT t w m)) dm' = do
115+ let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t w]) k) (EventWriterT t w m) m
116+ inputTransform = DMapTransform WrapArg (\(EventWriterT v) -> swap <$> runStateT v mempty)
117+ (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'
118+ let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
119+ result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
120+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Identity . snd . runIdentity) mv)) p
121+ requests0 :: DMap (Const2 (Some k) w) (Event t)
122+ requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mconcat (reverse r)) children0
123+ requests' :: Event t (PatchDMap (Const2 (Some k) w) (Event t))
124+ requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $
125+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mconcat . reverse . fst . runIdentity) mv)) p
126+ childRequestMap <- holdIncremental requests0 requests'
127+ -- 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.)
128+ EventWriterT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mconcat $ reverse $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me
129+ EventWriterT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->
130+ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m
131+ return (result0, result')
133+instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
134+ type Performable (EventWriterT t w m) = Performable m
135+ performEvent_ = lift . performEvent_
136+ performEvent = lift . performEvent
138+instance PostBuild t m => PostBuild t (EventWriterT t w m) where
139+ getPostBuild = lift getPostBuild
141+instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
142+ newTriggerEvent = lift newTriggerEvent
143+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
144+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
146+instance MonadReader r m => MonadReader r (EventWriterT t w m) where
148+ local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
149+ reader = lift . reader
151+instance MonadRef m => MonadRef (EventWriterT t w m) where
152+ type Ref (EventWriterT t w m) = Ref m
153+ newRef = lift . newRef
154+ readRef = lift . readRef
155+ writeRef r = lift . writeRef r
157+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
158+ newEventWithTrigger = lift . newEventWithTrigger
159+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
161+--------------------------------------------------------------------------------
162+-- Internal functions
163+--------------------------------------------------------------------------------
165+data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)
167+mapPatchKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> PatchDMap k v -> PatchDMap k' v'
168+mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> case x of DMapTransform f g -> f k :=> ComposeMaybe (fmap g mv)) p
170+mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'
171+mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of
172+ DMapTransform f g -> f k :=> g v