git.iko.soy/patch
on 9cc8f7b help sign in
patch/src/Reflex/PerformEvent/Base.hs
178 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.Host.Class
29import Reflex.PerformEvent.Class
30import Reflex.Requester.Base
31import Reflex.Requester.Class
33import Control.Lens
34import Control.Monad.Exception
35import Control.Monad.Identity
36import Control.Monad.Primitive
37import Control.Monad.Reader
38import Control.Monad.Ref
39import Data.Coerce
40import Data.Dependent.Map (DMap)
41import qualified Data.Dependent.Map as DMap
42import Data.Dependent.Sum
43import Data.IntMap.Strict (IntMap)
44import qualified Data.IntMap.Strict as IntMap
45import qualified Data.Semigroup as S
47-- | A function that fires events for the given 'EventTrigger's and then runs
48-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'
49-- action will be run once for the initial trigger execution as well as once for
50-- each followup.
51newtype 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?
53-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the
54-- name, 'PerformEventT' is not an instance of 'MonadTrans'.
55newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }
57deriving instance ReflexHost t => Functor (PerformEventT t m)
58deriving instance ReflexHost t => Applicative (PerformEventT t m)
59deriving instance ReflexHost t => Monad (PerformEventT t m)
60deriving instance ReflexHost t => MonadFix (PerformEventT t m)
61deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
62deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
63deriving instance (ReflexHost t, Applicative m, Monoid a) => Monoid (PerformEventT t m a)
64deriving instance (ReflexHost t, Applicative m, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
66instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
67 type PrimState (PerformEventT t m) = PrimState (HostFrame t)
68 primitive = PerformEventT . lift . primitive
70instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where
71 type Performable (PerformEventT t m) = HostFrame t
72 {-# INLINABLE performEvent_ #-}
73 performEvent_ = PerformEventT . requesting_
74 {-# INLINABLE performEvent #-}
75 performEvent = PerformEventT . requestingIdentity
77instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
78 runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
79 where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
80 f a0 a' = do
81 result0 <- lift a0
82 result' <- requestingIdentity a'
83 return (result0, result')
84 traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
85 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
86 traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
88defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
89 => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
90 -> (forall a. k' a -> v a -> HostFrame t (v2 a))
91 -> DMap k' v
92 -> Event t (p k' v)
93 -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2))
94defaultAdjustBase traversePatchWithKey f' dm0 dm' = do
95 result0 <- lift $ DMap.traverseWithKey f' dm0
96 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
97 return (result0, result')
99defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
100 => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))
101 -> (IntMap.Key -> v -> HostFrame t v2)
102 -> IntMap v
103 -> Event t (p v)
104 -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))
105defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do
106 result0 <- lift $ IntMap.traverseWithKey f' dm0
107 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
108 return (result0, result')
110instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
111 {-# INLINABLE newEventWithTrigger #-}
112 newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
113 {-# INLINABLE newFanEventWithTrigger #-}
114 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
116-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the
117-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run
118-- at the appropriate time.
119{-# INLINABLE hostPerformEventT #-}
120hostPerformEventT :: forall t m a.
121 ( Monad m
122 , MonadSubscribeEvent t m
123 , MonadReflexHost t m
124 , MonadRef m
125 , Ref m ~ Ref IO
126 )
127 => PerformEventT t m a
128 -> m (a, FireCommand t m)
129hostPerformEventT a = do
130 (response, responseTrigger) <- newEventWithTriggerRef
131 (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
132 eventToPerformHandle <- subscribeEvent eventToPerform
133 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
134 let go :: [DSum (EventTrigger t) Identity] -> m [a']
135 go ts = do
136 (result', mToPerform) <- fireEventsAndRead ts $ do
137 mToPerform <- sequence =<< readEvent eventToPerformHandle
138 result' <- readPhase
139 return (result', mToPerform)
140 case mToPerform of
141 Nothing -> return [result']
142 Just toPerform -> do
143 responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform
144 mrt <- readRef responseTrigger
145 let followupEventTriggers = case mrt of
146 Just rt -> [rt :=> Identity responses]
147 Nothing -> []
148 (result':) <$> go followupEventTriggers
149 go triggers
151instance ReflexHost t => MonadSample t (PerformEventT t m) where
152 {-# INLINABLE sample #-}
153 sample = PerformEventT . lift . sample
155instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
156 {-# INLINABLE hold #-}
157 hold v0 v' = PerformEventT $ lift $ hold v0 v'
158 {-# INLINABLE holdDyn #-}
159 holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
160 {-# INLINABLE holdIncremental #-}
161 holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
162 {-# INLINABLE buildDynamic #-}
163 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
164 {-# INLINABLE headE #-}
165 headE = PerformEventT . lift . headE
167instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
168 type Ref (PerformEventT t m) = Ref (HostFrame t)
169 {-# INLINABLE newRef #-}
170 newRef = PerformEventT . lift . newRef
171 {-# INLINABLE readRef #-}
172 readRef = PerformEventT . lift . readRef
173 {-# INLINABLE writeRef #-}
174 writeRef r = PerformEventT . lift . writeRef r
176instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
177 {-# INLINABLE atomicModifyRef #-}
178 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r