git.iko.soy/reflex
on ae@dev-script help sign in
reflex/src/Reflex/PerformEvent/Base.hs
179 lines 8.9 kB history raw
1-- | This module provides 'PerformEventT', the standard implementation of
2-- 'PerformEvent'.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE GADTs #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE PartialTypeSignatures #-}
11{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE UndecidableInstances #-}
18#ifdef USE_REFLEX_OPTIMIZER
19{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
20#endif
21module Reflex.PerformEvent.Base
22 ( PerformEventT (..)
23 , FireCommand (..)
24 , hostPerformEventT
25 ) where
27import Reflex.Class
28import Reflex.Adjustable.Class
29import Reflex.Host.Class
30import Reflex.PerformEvent.Class
31import Reflex.Requester.Base
32import Reflex.Requester.Class
34import Control.Lens
35import Control.Monad.Exception
36import Control.Monad.Identity
37import Control.Monad.Primitive
38import Control.Monad.Reader
39import Control.Monad.Ref
40import Data.Coerce
41import Data.Dependent.Map (DMap)
42import qualified Data.Dependent.Map as DMap
43import Data.Dependent.Sum
44import Data.IntMap.Strict (IntMap)
45import qualified Data.IntMap.Strict as IntMap
46import qualified Data.Semigroup as S
48-- | A function that fires events for the given 'EventTrigger's and then runs
49-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'
50-- action will be run once for the initial trigger execution as well as once for
51-- each followup.
52newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?
54-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the
55-- name, 'PerformEventT' is not an instance of 'MonadTrans'.
56newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }
58deriving instance ReflexHost t => Functor (PerformEventT t m)
59deriving instance ReflexHost t => Applicative (PerformEventT t m)
60deriving instance ReflexHost t => Monad (PerformEventT t m)
61deriving instance ReflexHost t => MonadFix (PerformEventT t m)
62deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
63deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
64deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a)
65deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
67instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
68 type PrimState (PerformEventT t m) = PrimState (HostFrame t)
69 primitive = PerformEventT . lift . primitive
71instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where
72 type Performable (PerformEventT t m) = HostFrame t
73 {-# INLINABLE performEvent_ #-}
74 performEvent_ = PerformEventT . requesting_
75 {-# INLINABLE performEvent #-}
76 performEvent = PerformEventT . requestingIdentity
78instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
79 runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
80 where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
81 f a0 a' = do
82 result0 <- lift a0
83 result' <- requestingIdentity a'
84 return (result0, result')
85 traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
86 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
87 traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
89defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
90 => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
91 -> (forall a. k' a -> v a -> HostFrame t (v2 a))
92 -> DMap k' v
93 -> Event t (p k' v)
94 -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2))
95defaultAdjustBase traversePatchWithKey f' dm0 dm' = do
96 result0 <- lift $ DMap.traverseWithKey f' dm0
97 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
98 return (result0, result')
100defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
101 => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))
102 -> (IntMap.Key -> v -> HostFrame t v2)
103 -> IntMap v
104 -> Event t (p v)
105 -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))
106defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do
107 result0 <- lift $ IntMap.traverseWithKey f' dm0
108 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
109 return (result0, result')
111instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
112 {-# INLINABLE newEventWithTrigger #-}
113 newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
114 {-# INLINABLE newFanEventWithTrigger #-}
115 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
117-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the
118-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run
119-- at the appropriate time.
120{-# INLINABLE hostPerformEventT #-}
121hostPerformEventT :: forall t m a.
122 ( Monad m
123 , MonadSubscribeEvent t m
124 , MonadReflexHost t m
125 , MonadRef m
126 , Ref m ~ Ref IO
127 )
128 => PerformEventT t m a
129 -> m (a, FireCommand t m)
130hostPerformEventT a = do
131 (response, responseTrigger) <- newEventWithTriggerRef
132 (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
133 eventToPerformHandle <- subscribeEvent eventToPerform
134 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
135 let go :: [DSum (EventTrigger t) Identity] -> m [a']
136 go ts = do
137 (result', mToPerform) <- fireEventsAndRead ts $ do
138 mToPerform <- sequence =<< readEvent eventToPerformHandle
139 result' <- readPhase
140 return (result', mToPerform)
141 case mToPerform of
142 Nothing -> return [result']
143 Just toPerform -> do
144 responses <- runHostFrame $ traverseRequesterData (fmap Identity) toPerform
145 mrt <- readRef responseTrigger
146 let followupEventTriggers = case mrt of
147 Just rt -> [rt :=> Identity responses]
148 Nothing -> []
149 (result':) <$> go followupEventTriggers
150 go triggers
152instance ReflexHost t => MonadSample t (PerformEventT t m) where
153 {-# INLINABLE sample #-}
154 sample = PerformEventT . lift . sample
156instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
157 {-# INLINABLE hold #-}
158 hold v0 v' = PerformEventT $ lift $ hold v0 v'
159 {-# INLINABLE holdDyn #-}
160 holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
161 {-# INLINABLE holdIncremental #-}
162 holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
163 {-# INLINABLE buildDynamic #-}
164 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
165 {-# INLINABLE headE #-}
166 headE = PerformEventT . lift . headE
168instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
169 type Ref (PerformEventT t m) = Ref (HostFrame t)
170 {-# INLINABLE newRef #-}
171 newRef = PerformEventT . lift . newRef
172 {-# INLINABLE readRef #-}
173 readRef = PerformEventT . lift . readRef
174 {-# INLINABLE writeRef #-}
175 writeRef r = PerformEventT . lift . writeRef r
177instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
178 {-# INLINABLE atomicModifyRef #-}
179 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r