git.iko.soy/reflex
on ae@dev-script help sign in
reflex/src/Reflex/PostBuild/Base.hs
197 lines 8.2 kB history raw
1-- | This module defines 'PostBuildT', the standard implementation of
2-- 'PostBuild'.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE DataKinds #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE UndecidableInstances #-}
14#ifdef USE_REFLEX_OPTIMIZER
15{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16#endif
17module Reflex.PostBuild.Base
18 ( PostBuildT (..)
19 , runPostBuildT
20 -- * Internal
21 , mapIntMapWithAdjustImpl
22 , mapDMapWithAdjustImpl
23 ) where
25import Reflex.Class
26import Reflex.Adjustable.Class
27import Reflex.Host.Class
28import Reflex.PerformEvent.Class
29import Reflex.PostBuild.Class
30import Reflex.TriggerEvent.Class
32import Control.Applicative (liftA2)
33import Control.Monad.Exception
34import Control.Monad.Identity
35import Control.Monad.Primitive
36import Control.Monad.Reader
37import Control.Monad.Ref
38import qualified Control.Monad.Trans.Control as TransControl
39import Data.Dependent.Map (DMap)
40import qualified Data.Dependent.Map as DMap
41import Data.Functor.Compose
42import Data.IntMap.Strict (IntMap)
43import qualified Data.IntMap.Strict as IntMap
44import qualified Data.Semigroup as S
46-- | Provides a basic implementation of 'PostBuild'.
47newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
49-- | Run a 'PostBuildT' action. An 'Event' should be provided that fires
50-- immediately after the action is finished running; no other 'Event's should
51-- fire first.
52{-# INLINABLE runPostBuildT #-}
53runPostBuildT :: PostBuildT t m a -> Event t () -> m a
54runPostBuildT (PostBuildT a) = runReaderT a
56-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.
57instance (Monoid a, Applicative m) => Monoid (PostBuildT t m a) where
58 mempty = pure mempty
59 mappend = liftA2 mappend
61instance (S.Semigroup a, Applicative m) => S.Semigroup (PostBuildT t m a) where
62 (<>) = liftA2 (S.<>)
64instance PrimMonad m => PrimMonad (PostBuildT x m) where
65 type PrimState (PostBuildT x m) = PrimState m
66 primitive = lift . primitive
68instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
69 {-# INLINABLE getPostBuild #-}
70 getPostBuild = PostBuildT ask
72instance MonadSample t m => MonadSample t (PostBuildT t m) where
73 {-# INLINABLE sample #-}
74 sample = lift . sample
76instance MonadHold t m => MonadHold t (PostBuildT t m) where
77 {-# INLINABLE hold #-}
78 hold v0 = lift . hold v0
79 {-# INLINABLE holdDyn #-}
80 holdDyn v0 = lift . holdDyn v0
81 {-# INLINABLE holdIncremental #-}
82 holdIncremental v0 = lift . holdIncremental v0
83 {-# INLINABLE buildDynamic #-}
84 buildDynamic a0 = lift . buildDynamic a0
85 {-# INLINABLE headE #-}
86 headE = lift . headE
88instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
89 type Performable (PostBuildT t m) = Performable m
90 {-# INLINABLE performEvent_ #-}
91 performEvent_ = lift . performEvent_
92 {-# INLINABLE performEvent #-}
93 performEvent = lift . performEvent
95instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
96 {-# INLINABLE newEventWithTrigger #-}
97 newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
98 {-# INLINABLE newFanEventWithTrigger #-}
99 newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
101instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
102 {-# INLINABLE newTriggerEvent #-}
103 newTriggerEvent = lift newTriggerEvent
104 {-# INLINABLE newTriggerEventWithOnComplete #-}
105 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
106 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
108instance MonadRef m => MonadRef (PostBuildT t m) where
109 type Ref (PostBuildT t m) = Ref m
110 {-# INLINABLE newRef #-}
111 newRef = lift . newRef
112 {-# INLINABLE readRef #-}
113 readRef = lift . readRef
114 {-# INLINABLE writeRef #-}
115 writeRef r = lift . writeRef r
117instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
118 {-# INLINABLE atomicModifyRef #-}
119 atomicModifyRef r = lift . atomicModifyRef r
121instance (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, PerformEvent t m) => Adjustable t (PostBuildT t m) where
122 runWithReplace a0 a' = do
123 postBuild <- getPostBuild
124 lift $ do
125 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
126 let voidResult' = fmapCheap (\_ -> ()) result'
127 return result
128 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
129 traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust
130 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
131 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap
132 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
134{-# INLINABLE mapIntMapWithAdjustImpl #-}
135mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)
136 => ( (IntMap.Key -> (Event t (), v) -> m v')
137 -> IntMap (Event t (), v)
138 -> Event t (p (Event t (), v))
139 -> m (IntMap v', Event t (p v'))
140 )
141 -> (IntMap.Key -> v -> PostBuildT t m v')
142 -> IntMap v
143 -> Event t (p v)
144 -> PostBuildT t m (IntMap v', Event t (p v'))
145mapIntMapWithAdjustImpl base f dm0 dm' = do
146 postBuild <- getPostBuild
147 let loweredDm0 = fmap ((,) postBuild) dm0
148 f' :: IntMap.Key -> (Event t (), v) -> m v'
149 f' k (e, v) = do
150 runPostBuildT (f k v) e
151 lift $ do
152 rec (result0, result') <- base f' loweredDm0 loweredDm'
153 cohortDone <- numberOccurrencesFrom_ 1 result'
154 numberedDm' <- numberOccurrencesFrom 1 dm'
155 let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone
156 loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do
157 return $ fmap ((,) (selectInt postBuild' n)) p
158 return (result0, result')
160{-# INLINABLE mapDMapWithAdjustImpl #-}
161mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)
162 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))
163 -> DMap k (Compose ((,) (Bool, Event t ())) v)
164 -> Event t (p k (Compose ((,) (Bool, Event t ())) v))
165 -> m (DMap k v', Event t (p k v'))
166 )
167 -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))
168 -> (forall a. k a -> v a -> PostBuildT t m (v' a))
169 -> DMap k v
170 -> Event t (p k v)
171 -> PostBuildT t m (DMap k v', Event t (p k v'))
172mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do
173 postBuild <- getPostBuild
174 let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0
175 f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)
176 f' k (Compose ((shouldHeadE, e), v)) = do
177 eOnce <- if shouldHeadE
178 then headE e --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence
179 else return e
180 runPostBuildT (f k v) eOnce
181 lift $ do
182 rec (result0, result') <- base f' loweredDm0 loweredDm'
183 let voidResult' = fmapCheap (\_ -> ()) result'
184 let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))
185 return (result0, result')
187--------------------------------------------------------------------------------
188-- Deprecated functionality
189--------------------------------------------------------------------------------
191-- | Deprecated
192instance TransControl.MonadTransControl (PostBuildT t) where
193 type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a
194 {-# INLINABLE liftWith #-}
195 liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT
196 {-# INLINABLE restoreT #-}
197 restoreT = TransControl.defaultRestoreT PostBuildT