git.iko.soy/patch
on fab8302 help sign in
patch/src/Reflex/PostBuild/Base.hs
186 lines 7.8 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.Monad.Exception
32import Control.Monad.Identity
33import Control.Monad.Primitive
34import Control.Monad.Reader
35import Control.Monad.Ref
36import qualified Control.Monad.Trans.Control as TransControl
37import Data.Dependent.Map (DMap)
38import qualified Data.Dependent.Map as DMap
39import Data.Functor.Compose
40import Data.IntMap.Strict (IntMap)
41import qualified Data.IntMap.Strict as IntMap
43-- | Provides a basic implementation of 'PostBuild'.
44newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
46-- | Run a 'PostBuildT' action. An 'Event' should be provided that fires
47-- immediately after the action is finished running; no other 'Event's should
48-- fire first.
49{-# INLINABLE runPostBuildT #-}
50runPostBuildT :: PostBuildT t m a -> Event t () -> m a
51runPostBuildT (PostBuildT a) = runReaderT a
53instance PrimMonad m => PrimMonad (PostBuildT x m) where
54 type PrimState (PostBuildT x m) = PrimState m
55 primitive = lift . primitive
57instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
58 {-# INLINABLE getPostBuild #-}
59 getPostBuild = PostBuildT ask
61instance MonadSample t m => MonadSample t (PostBuildT t m) where
62 {-# INLINABLE sample #-}
63 sample = lift . sample
65instance MonadHold t m => MonadHold t (PostBuildT t m) where
66 {-# INLINABLE hold #-}
67 hold v0 = lift . hold v0
68 {-# INLINABLE holdDyn #-}
69 holdDyn v0 = lift . holdDyn v0
70 {-# INLINABLE holdIncremental #-}
71 holdIncremental v0 = lift . holdIncremental v0
72 {-# INLINABLE buildDynamic #-}
73 buildDynamic a0 = lift . buildDynamic a0
74 {-# INLINABLE headE #-}
75 headE = lift . headE
77instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
78 type Performable (PostBuildT t m) = Performable m
79 {-# INLINABLE performEvent_ #-}
80 performEvent_ = lift . performEvent_
81 {-# INLINABLE performEvent #-}
82 performEvent = lift . performEvent
84instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
85 {-# INLINABLE newEventWithTrigger #-}
86 newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
87 {-# INLINABLE newFanEventWithTrigger #-}
88 newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
90instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
91 {-# INLINABLE newTriggerEvent #-}
92 newTriggerEvent = lift newTriggerEvent
93 {-# INLINABLE newTriggerEventWithOnComplete #-}
94 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
95 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
97instance MonadRef m => MonadRef (PostBuildT t m) where
98 type Ref (PostBuildT t m) = Ref m
99 {-# INLINABLE newRef #-}
100 newRef = lift . newRef
101 {-# INLINABLE readRef #-}
102 readRef = lift . readRef
103 {-# INLINABLE writeRef #-}
104 writeRef r = lift . writeRef r
106instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
107 {-# INLINABLE atomicModifyRef #-}
108 atomicModifyRef r = lift . atomicModifyRef r
110instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where
111 runWithReplace a0 a' = do
112 postBuild <- getPostBuild
113 lift $ do
114 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
115 let voidResult' = fmapCheap (\_ -> ()) result'
116 return result
117 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
118 traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust
119 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
120 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap
121 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
123{-# INLINABLE mapIntMapWithAdjustImpl #-}
124mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)
125 => ( (IntMap.Key -> (Event t (), v) -> m v')
126 -> IntMap (Event t (), v)
127 -> Event t (p (Event t (), v))
128 -> m (IntMap v', Event t (p v'))
129 )
130 -> (IntMap.Key -> v -> PostBuildT t m v')
131 -> IntMap v
132 -> Event t (p v)
133 -> PostBuildT t m (IntMap v', Event t (p v'))
134mapIntMapWithAdjustImpl base f dm0 dm' = do
135 postBuild <- getPostBuild
136 let loweredDm0 = fmap ((,) postBuild) dm0
137 f' :: IntMap.Key -> (Event t (), v) -> m v'
138 f' k (e, v) = do
139 runPostBuildT (f k v) e
140 lift $ do
141 rec (result0, result') <- base f' loweredDm0 loweredDm'
142 cohortDone <- numberOccurrencesFrom_ 1 result'
143 numberedDm' <- numberOccurrencesFrom 1 dm'
144 let postBuild' = fanInt $ fmapCheap (\n -> IntMap.singleton n ()) cohortDone
145 loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do
146 return $ fmap ((,) (selectInt postBuild' n)) p
147 return (result0, result')
149{-# INLINABLE mapDMapWithAdjustImpl #-}
150mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)
151 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))
152 -> DMap k (Compose ((,) (Bool, Event t ())) v)
153 -> Event t (p k (Compose ((,) (Bool, Event t ())) v))
154 -> m (DMap k v', Event t (p k v'))
155 )
156 -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))
157 -> (forall a. k a -> v a -> PostBuildT t m (v' a))
158 -> DMap k v
159 -> Event t (p k v)
160 -> PostBuildT t m (DMap k v', Event t (p k v'))
161mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do
162 postBuild <- getPostBuild
163 let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0
164 f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)
165 f' k (Compose ((shouldHeadE, e), v)) = do
166 eOnce <- if shouldHeadE
167 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
168 else return e
169 runPostBuildT (f k v) eOnce
170 lift $ do
171 rec (result0, result') <- base f' loweredDm0 loweredDm'
172 let voidResult' = fmapCheap (\_ -> ()) result'
173 let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))
174 return (result0, result')
176--------------------------------------------------------------------------------
177-- Deprecated functionality
178--------------------------------------------------------------------------------
180-- | Deprecated
181instance TransControl.MonadTransControl (PostBuildT t) where
182 type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a
183 {-# INLINABLE liftWith #-}
184 liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT
185 {-# INLINABLE restoreT #-}
186 restoreT = TransControl.defaultRestoreT PostBuildT