git.iko.soy/reflex
on dc3bf44 help sign in
reflex/src/Reflex/PostBuild/Base.hs
199 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
87 {-# INLINABLE now #-}
88 now = lift now
90instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
91 type Performable (PostBuildT t m) = Performable m
92 {-# INLINABLE performEvent_ #-}
93 performEvent_ = lift . performEvent_
94 {-# INLINABLE performEvent #-}
95 performEvent = lift . performEvent
97instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
98 {-# INLINABLE newEventWithTrigger #-}
99 newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
100 {-# INLINABLE newFanEventWithTrigger #-}
101 newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
103instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
104 {-# INLINABLE newTriggerEvent #-}
105 newTriggerEvent = lift newTriggerEvent
106 {-# INLINABLE newTriggerEventWithOnComplete #-}
107 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
108 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
110instance MonadRef m => MonadRef (PostBuildT t m) where
111 type Ref (PostBuildT t m) = Ref m
112 {-# INLINABLE newRef #-}
113 newRef = lift . newRef
114 {-# INLINABLE readRef #-}
115 readRef = lift . readRef
116 {-# INLINABLE writeRef #-}
117 writeRef r = lift . writeRef r
119instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
120 {-# INLINABLE atomicModifyRef #-}
121 atomicModifyRef r = lift . atomicModifyRef r
123instance (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, PerformEvent t m) => Adjustable t (PostBuildT t m) where
124 runWithReplace a0 a' = do
125 postBuild <- getPostBuild
126 lift $ do
127 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
128 let voidResult' = fmapCheap (\_ -> ()) result'
129 return result
130 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
131 traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust
132 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
133 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap
134 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
136{-# INLINABLE mapIntMapWithAdjustImpl #-}
137mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)
138 => ( (IntMap.Key -> (Event t (), v) -> m v')
139 -> IntMap (Event t (), v)
140 -> Event t (p (Event t (), v))
141 -> m (IntMap v', Event t (p v'))
142 )
143 -> (IntMap.Key -> v -> PostBuildT t m v')
144 -> IntMap v
145 -> Event t (p v)
146 -> PostBuildT t m (IntMap v', Event t (p v'))
147mapIntMapWithAdjustImpl base f dm0 dm' = do
148 postBuild <- getPostBuild
149 let loweredDm0 = fmap ((,) postBuild) dm0
150 f' :: IntMap.Key -> (Event t (), v) -> m v'
151 f' k (e, v) = do
152 runPostBuildT (f k v) e
153 lift $ do
154 rec (result0, result') <- base f' loweredDm0 loweredDm'
155 cohortDone <- numberOccurrencesFrom_ 1 result'
156 numberedDm' <- numberOccurrencesFrom 1 dm'
157 let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone
158 loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do
159 return $ fmap ((,) (selectInt postBuild' n)) p
160 return (result0, result')
162{-# INLINABLE mapDMapWithAdjustImpl #-}
163mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)
164 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))
165 -> DMap k (Compose ((,) (Bool, Event t ())) v)
166 -> Event t (p k (Compose ((,) (Bool, Event t ())) v))
167 -> m (DMap k v', Event t (p k v'))
168 )
169 -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))
170 -> (forall a. k a -> v a -> PostBuildT t m (v' a))
171 -> DMap k v
172 -> Event t (p k v)
173 -> PostBuildT t m (DMap k v', Event t (p k v'))
174mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do
175 postBuild <- getPostBuild
176 let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0
177 f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)
178 f' k (Compose ((shouldHeadE, e), v)) = do
179 eOnce <- if shouldHeadE
180 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
181 else return e
182 runPostBuildT (f k v) eOnce
183 lift $ do
184 rec (result0, result') <- base f' loweredDm0 loweredDm'
185 let voidResult' = fmapCheap (\_ -> ()) result'
186 let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))
187 return (result0, result')
189--------------------------------------------------------------------------------
190-- Deprecated functionality
191--------------------------------------------------------------------------------
193-- | Deprecated
194instance TransControl.MonadTransControl (PostBuildT t) where
195 type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a
196 {-# INLINABLE liftWith #-}
197 liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT
198 {-# INLINABLE restoreT #-}
199 restoreT = TransControl.defaultRestoreT PostBuildT