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