git.iko.soy/patch
on c617057 help sign in
patch/src/Reflex/PerformEvent/Base.hs
159 lines 7.7 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
44-- | A function that fires events for the given 'EventTrigger's and then runs
45-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'
46-- action will be run once for the initial trigger execution as well as once for
47-- each followup.
48newtype 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?
50-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the
51-- name, 'PerformEventT' is not an instance of 'MonadTrans'.
52newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }
54deriving instance ReflexHost t => Functor (PerformEventT t m)
55deriving instance ReflexHost t => Applicative (PerformEventT t m)
56deriving instance ReflexHost t => Monad (PerformEventT t m)
57deriving instance ReflexHost t => MonadFix (PerformEventT t m)
58deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
59deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
61instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
62 type PrimState (PerformEventT t m) = PrimState (HostFrame t)
63 primitive = PerformEventT . lift . primitive
65instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where
66 type Performable (PerformEventT t m) = HostFrame t
67 {-# INLINABLE performEvent_ #-}
68 performEvent_ = PerformEventT . requesting_
69 {-# INLINABLE performEvent #-}
70 performEvent = PerformEventT . requestingIdentity
72instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where
73 runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
74 where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
75 f a0 a' = do
76 result0 <- lift a0
77 result' <- requestingIdentity a'
78 return (result0, result')
79 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
80 traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
82defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
83 => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
84 -> (forall a. k' a -> v a -> HostFrame t (v2 a))
85 -> DMap k' v
86 -> Event t (p k' v)
87 -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2))
88defaultAdjustBase traversePatchWithKey f' dm0 dm' = do
89 result0 <- lift $ DMap.traverseWithKey f' dm0
90 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
91 return (result0, result')
93instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
94 {-# INLINABLE newEventWithTrigger #-}
95 newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
96 {-# INLINABLE newFanEventWithTrigger #-}
97 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
99-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the
100-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run
101-- at the appropriate time.
102{-# INLINABLE hostPerformEventT #-}
103hostPerformEventT :: forall t m a.
104 ( Monad m
105 , MonadSubscribeEvent t m
106 , MonadReflexHost t m
107 , MonadRef m
108 , Ref m ~ Ref IO
109 )
110 => PerformEventT t m a
111 -> m (a, FireCommand t m)
112hostPerformEventT a = do
113 (response, responseTrigger) <- newEventWithTriggerRef
114 (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
115 eventToPerformHandle <- subscribeEvent eventToPerform
116 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
117 let go :: [DSum (EventTrigger t) Identity] -> m [a']
118 go ts = do
119 (result', mToPerform) <- fireEventsAndRead ts $ do
120 mToPerform <- sequence =<< readEvent eventToPerformHandle
121 result' <- readPhase
122 return (result', mToPerform)
123 case mToPerform of
124 Nothing -> return [result']
125 Just toPerform -> do
126 responses <- runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform
127 mrt <- readRef responseTrigger
128 let followupEventTriggers = case mrt of
129 Just rt -> [rt :=> Identity responses]
130 Nothing -> []
131 (result':) <$> go followupEventTriggers
132 go triggers
134instance ReflexHost t => MonadSample t (PerformEventT t m) where
135 {-# INLINABLE sample #-}
136 sample = PerformEventT . lift . sample
138instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
139 {-# INLINABLE hold #-}
140 hold v0 v' = PerformEventT $ lift $ hold v0 v'
141 {-# INLINABLE holdDyn #-}
142 holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
143 {-# INLINABLE holdIncremental #-}
144 holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
145 {-# INLINABLE buildDynamic #-}
146 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
148instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
149 type Ref (PerformEventT t m) = Ref (HostFrame t)
150 {-# INLINABLE newRef #-}
151 newRef = PerformEventT . lift . newRef
152 {-# INLINABLE readRef #-}
153 readRef = PerformEventT . lift . readRef
154 {-# INLINABLE writeRef #-}
155 writeRef r = PerformEventT . lift . writeRef r
157instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
158 {-# INLINABLE atomicModifyRef #-}
159 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r