git.iko.soy/reflex
on develop help sign in
reflex/src/Reflex/PostBuild/Base.hs
198 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 UndecidableInstances #-}
13#ifdef USE_REFLEX_OPTIMIZER
14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15#endif
16module Reflex.PostBuild.Base
17 ( PostBuildT (..)
18 , runPostBuildT
19 -- * Internal
20 , mapIntMapWithAdjustImpl
21 , mapDMapWithAdjustImpl
22 ) where
24import Reflex.Class
25import Reflex.Adjustable.Class
26import Reflex.Host.Class
27import Reflex.PerformEvent.Class
28import Reflex.PostBuild.Class
29import Reflex.TriggerEvent.Class
31import Control.Applicative (liftA2)
32import Control.Monad.Exception
33import Control.Monad.Identity
34import Control.Monad.Primitive
35import Control.Monad.Reader
36import Control.Monad.Ref
37import qualified Control.Monad.Trans.Control as TransControl
38import Data.Dependent.Map (DMap)
39import qualified Data.Dependent.Map as DMap
40import Data.Functor.Compose
41import Data.IntMap.Strict (IntMap)
42import qualified Data.IntMap.Strict as IntMap
43import qualified Data.Semigroup as S
45-- | Provides a basic implementation of 'PostBuild'.
46newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
48-- | Run a 'PostBuildT' action. An 'Event' should be provided that fires
49-- immediately after the action is finished running; no other 'Event's should
50-- fire first.
51{-# INLINABLE runPostBuildT #-}
52runPostBuildT :: PostBuildT t m a -> Event t () -> m a
53runPostBuildT (PostBuildT a) = runReaderT a
55-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.
56instance (Monoid a, Applicative m) => Monoid (PostBuildT t m a) where
57 mempty = pure mempty
58 mappend = liftA2 mappend
60instance (S.Semigroup a, Applicative m) => S.Semigroup (PostBuildT t m a) where
61 (<>) = liftA2 (S.<>)
63instance PrimMonad m => PrimMonad (PostBuildT x m) where
64 type PrimState (PostBuildT x m) = PrimState m
65 primitive = lift . primitive
67instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
68 {-# INLINABLE getPostBuild #-}
69 getPostBuild = PostBuildT ask
71instance MonadSample t m => MonadSample t (PostBuildT t m) where
72 {-# INLINABLE sample #-}
73 sample = lift . sample
75instance MonadHold t m => MonadHold t (PostBuildT t m) where
76 {-# INLINABLE hold #-}
77 hold v0 = lift . hold v0
78 {-# INLINABLE holdDyn #-}
79 holdDyn v0 = lift . holdDyn v0
80 {-# INLINABLE holdIncremental #-}
81 holdIncremental v0 = lift . holdIncremental v0
82 {-# INLINABLE buildDynamic #-}
83 buildDynamic a0 = lift . buildDynamic a0
84 {-# INLINABLE headE #-}
85 headE = lift . headE
86 {-# INLINABLE now #-}
87 now = lift now
89instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
90 type Performable (PostBuildT t m) = Performable m
91 {-# INLINABLE performEvent_ #-}
92 performEvent_ = lift . performEvent_
93 {-# INLINABLE performEvent #-}
94 performEvent = lift . performEvent
96instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
97 {-# INLINABLE newEventWithTrigger #-}
98 newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
99 {-# INLINABLE newFanEventWithTrigger #-}
100 newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
102instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
103 {-# INLINABLE newTriggerEvent #-}
104 newTriggerEvent = lift newTriggerEvent
105 {-# INLINABLE newTriggerEventWithOnComplete #-}
106 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
107 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
109instance MonadRef m => MonadRef (PostBuildT t m) where
110 type Ref (PostBuildT t m) = Ref m
111 {-# INLINABLE newRef #-}
112 newRef = lift . newRef
113 {-# INLINABLE readRef #-}
114 readRef = lift . readRef
115 {-# INLINABLE writeRef #-}
116 writeRef r = lift . writeRef r
118instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
119 {-# INLINABLE atomicModifyRef #-}
120 atomicModifyRef r = lift . atomicModifyRef r
122instance (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, PerformEvent t m) => Adjustable t (PostBuildT t m) where
123 runWithReplace a0 a' = do
124 postBuild <- getPostBuild
125 lift $ do
126 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
127 let voidResult' = fmapCheap (\_ -> ()) result'
128 return result
129 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
130 traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust
131 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
132 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap
133 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
135{-# INLINABLE mapIntMapWithAdjustImpl #-}
136mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)
137 => ( (IntMap.Key -> (Event t (), v) -> m v')
138 -> IntMap (Event t (), v)
139 -> Event t (p (Event t (), v))
140 -> m (IntMap v', Event t (p v'))
141 )
142 -> (IntMap.Key -> v -> PostBuildT t m v')
143 -> IntMap v
144 -> Event t (p v)
145 -> PostBuildT t m (IntMap v', Event t (p v'))
146mapIntMapWithAdjustImpl base f dm0 dm' = do
147 postBuild <- getPostBuild
148 let loweredDm0 = fmap ((,) postBuild) dm0
149 f' :: IntMap.Key -> (Event t (), v) -> m v'
150 f' k (e, v) = do
151 runPostBuildT (f k v) e
152 lift $ do
153 rec (result0, result') <- base f' loweredDm0 loweredDm'
154 cohortDone <- numberOccurrencesFrom_ 1 result'
155 numberedDm' <- numberOccurrencesFrom 1 dm'
156 let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone
157 loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do
158 return $ fmap ((,) (selectInt postBuild' n)) p
159 return (result0, result')
161{-# INLINABLE mapDMapWithAdjustImpl #-}
162mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)
163 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))
164 -> DMap k (Compose ((,) (Bool, Event t ())) v)
165 -> Event t (p k (Compose ((,) (Bool, Event t ())) v))
166 -> m (DMap k v', Event t (p k v'))
167 )
168 -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))
169 -> (forall a. k a -> v a -> PostBuildT t m (v' a))
170 -> DMap k v
171 -> Event t (p k v)
172 -> PostBuildT t m (DMap k v', Event t (p k v'))
173mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do
174 postBuild <- getPostBuild
175 let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0
176 f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)
177 f' k (Compose ((shouldHeadE, e), v)) = do
178 eOnce <- if shouldHeadE
179 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
180 else return e
181 runPostBuildT (f k v) eOnce
182 lift $ do
183 rec (result0, result') <- base f' loweredDm0 loweredDm'
184 let voidResult' = fmapCheap (\_ -> ()) result'
185 let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))
186 return (result0, result')
188--------------------------------------------------------------------------------
189-- Deprecated functionality
190--------------------------------------------------------------------------------
192-- | Deprecated
193instance TransControl.MonadTransControl (PostBuildT t) where
194 type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a
195 {-# INLINABLE liftWith #-}
196 liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT
197 {-# INLINABLE restoreT #-}
198 restoreT = TransControl.defaultRestoreT PostBuildT