git.iko.soy/patch
on 73658fd help sign in
patch/src/Reflex/PostBuild/Base.hs
177 lines 7.6 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 Control.Monad.Trans.Control
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 MonadTransControl (PostBuildT t) where
58 type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a
59 {-# INLINABLE liftWith #-}
60 liftWith = defaultLiftWith PostBuildT unPostBuildT
61 {-# INLINABLE restoreT #-}
62 restoreT = defaultRestoreT PostBuildT
64instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
65 {-# INLINABLE getPostBuild #-}
66 getPostBuild = PostBuildT ask
68instance MonadSample t m => MonadSample t (PostBuildT t m) where
69 {-# INLINABLE sample #-}
70 sample = lift . sample
72instance MonadHold t m => MonadHold t (PostBuildT t m) where
73 {-# INLINABLE hold #-}
74 hold v0 = lift . hold v0
75 {-# INLINABLE holdDyn #-}
76 holdDyn v0 = lift . holdDyn v0
77 {-# INLINABLE holdIncremental #-}
78 holdIncremental v0 = lift . holdIncremental v0
80instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
81 type Performable (PostBuildT t m) = PostBuildT t (Performable m)
82 {-# INLINABLE performEvent_ #-}
83 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
84 {-# INLINABLE performEvent #-}
85 performEvent e = liftWith $ \run -> performEvent $ fmap run e
87instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
88 {-# INLINABLE newEventWithTrigger #-}
89 newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
90 {-# INLINABLE newFanEventWithTrigger #-}
91 newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
93instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
94 {-# INLINABLE newTriggerEvent #-}
95 newTriggerEvent = lift newTriggerEvent
96 {-# INLINABLE newTriggerEventWithOnComplete #-}
97 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
98 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
100instance MonadRef m => MonadRef (PostBuildT t m) where
101 type Ref (PostBuildT t m) = Ref m
102 {-# INLINABLE newRef #-}
103 newRef = lift . newRef
104 {-# INLINABLE readRef #-}
105 readRef = lift . readRef
106 {-# INLINABLE writeRef #-}
107 writeRef r = lift . writeRef r
109instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
110 {-# INLINABLE atomicModifyRef #-}
111 atomicModifyRef r = lift . atomicModifyRef r
113instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where
114 runWithReplace a0 a' = do
115 postBuild <- getPostBuild
116 lift $ do
117 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
118 let voidResult' = fmapCheap (\_ -> ()) result'
119 return result
120 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
121 traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust
122 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
123 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap
124 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
126{-# INLINABLE mapIntMapWithAdjustImpl #-}
127mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)
128 => ( (IntMap.Key -> ((Bool, Event t ()), v) -> m v')
129 -> IntMap ((Bool, Event t ()), v)
130 -> Event t (p ((Bool, Event t ()), v))
131 -> m (IntMap v', Event t (p v'))
132 )
133 -> (IntMap.Key -> v -> PostBuildT t m v')
134 -> IntMap v
135 -> Event t (p v)
136 -> PostBuildT t m (IntMap v', Event t (p v'))
137mapIntMapWithAdjustImpl base f dm0 dm' = do
138 postBuild <- getPostBuild
139 let loweredDm0 = fmap ((,) (False, postBuild)) dm0
140 f' :: IntMap.Key -> ((Bool, Event t ()), v) -> m v'
141 f' k ((shouldHeadE, e), v) = do
142 eOnce <- if shouldHeadE
143 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
144 else return e
145 runPostBuildT (f k v) eOnce
146 lift $ do
147 rec (result0, result') <- base f' loweredDm0 loweredDm'
148 let voidResult' = fmapCheap (\_ -> ()) result'
149 let loweredDm' = ffor dm' $ fmap ((,) (True, voidResult'))
150 return (result0, result')
152{-# INLINABLE mapDMapWithAdjustImpl #-}
153mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)
154 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))
155 -> DMap k (Compose ((,) (Bool, Event t ())) v)
156 -> Event t (p k (Compose ((,) (Bool, Event t ())) v))
157 -> m (DMap k v', Event t (p k v'))
158 )
159 -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))
160 -> (forall a. k a -> v a -> PostBuildT t m (v' a))
161 -> DMap k v
162 -> Event t (p k v)
163 -> PostBuildT t m (DMap k v', Event t (p k v'))
164mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do
165 postBuild <- getPostBuild
166 let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0
167 f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)
168 f' k (Compose ((shouldHeadE, e), v)) = do
169 eOnce <- if shouldHeadE
170 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
171 else return e
172 runPostBuildT (f k v) eOnce
173 lift $ do
174 rec (result0, result') <- base f' loweredDm0 loweredDm'
175 let voidResult' = fmapCheap (\_ -> ()) result'
176 let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))
177 return (result0, result')