git.iko.soy/patch
on ae0af76 help sign in
patch/src/Reflex/PostBuild/Base.hs
142 lines 6.0 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 ) where
22import Reflex.Class
23import Reflex.Host.Class
24import Reflex.PerformEvent.Class
25import Reflex.PostBuild.Class
26import Reflex.TriggerEvent.Class
28import Control.Monad.Exception
29import Control.Monad.Identity
30import Control.Monad.Primitive
31import Control.Monad.Reader
32import Control.Monad.Ref
33import Control.Monad.Trans.Control
34import Data.Dependent.Map (DMap)
35import qualified Data.Dependent.Map as DMap
36import Data.Functor.Compose
38-- | Provides a basic implementation of 'PostBuild'.
39newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
41-- | Run a 'PostBuildT' action. An 'Event' should be provided that fires
42-- immediately after the action is finished running; no other 'Event's should
43-- fire first.
44{-# INLINABLE runPostBuildT #-}
45runPostBuildT :: PostBuildT t m a -> Event t () -> m a
46runPostBuildT (PostBuildT a) = runReaderT a
48instance PrimMonad m => PrimMonad (PostBuildT x m) where
49 type PrimState (PostBuildT x m) = PrimState m
50 primitive = lift . primitive
52instance MonadTransControl (PostBuildT t) where
53 type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a
54 {-# INLINABLE liftWith #-}
55 liftWith = defaultLiftWith PostBuildT unPostBuildT
56 {-# INLINABLE restoreT #-}
57 restoreT = defaultRestoreT PostBuildT
59instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
60 {-# INLINABLE getPostBuild #-}
61 getPostBuild = PostBuildT ask
63instance MonadSample t m => MonadSample t (PostBuildT t m) where
64 {-# INLINABLE sample #-}
65 sample = lift . sample
67instance MonadHold t m => MonadHold t (PostBuildT t m) where
68 {-# INLINABLE hold #-}
69 hold v0 = lift . hold v0
70 {-# INLINABLE holdDyn #-}
71 holdDyn v0 = lift . holdDyn v0
72 {-# INLINABLE holdIncremental #-}
73 holdIncremental v0 = lift . holdIncremental v0
75instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
76 type Performable (PostBuildT t m) = PostBuildT t (Performable m)
77 {-# INLINABLE performEvent_ #-}
78 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
79 {-# INLINABLE performEvent #-}
80 performEvent e = liftWith $ \run -> performEvent $ fmap run e
82instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
83 {-# INLINABLE newEventWithTrigger #-}
84 newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
85 {-# INLINABLE newFanEventWithTrigger #-}
86 newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
88instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
89 {-# INLINABLE newTriggerEvent #-}
90 newTriggerEvent = lift newTriggerEvent
91 {-# INLINABLE newTriggerEventWithOnComplete #-}
92 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
93 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
95instance MonadRef m => MonadRef (PostBuildT t m) where
96 type Ref (PostBuildT t m) = Ref m
97 {-# INLINABLE newRef #-}
98 newRef = lift . newRef
99 {-# INLINABLE readRef #-}
100 readRef = lift . readRef
101 {-# INLINABLE writeRef #-}
102 writeRef r = lift . writeRef r
104instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
105 {-# INLINABLE atomicModifyRef #-}
106 atomicModifyRef r = lift . atomicModifyRef r
108instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where
109 runWithReplace a0 a' = do
110 postBuild <- getPostBuild
111 lift $ do
112 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
113 let voidResult' = fmapCheap (\_ -> ()) result'
114 return result
115 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap
116 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
118mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)
119 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))
120 -> DMap k (Compose ((,) (Bool, Event t ())) v)
121 -> Event t (p k (Compose ((,) (Bool, Event t ())) v))
122 -> m (DMap k v', Event t (p k v'))
123 )
124 -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))
125 -> (forall a. k a -> v a -> PostBuildT t m (v' a))
126 -> DMap k v
127 -> Event t (p k v)
128 -> PostBuildT t m (DMap k v', Event t (p k v'))
129mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do
130 postBuild <- getPostBuild
131 let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0
132 f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)
133 f' k (Compose ((shouldHeadE, e), v)) = do
134 eOnce <- if shouldHeadE
135 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
136 else return e
137 runPostBuildT (f k v) eOnce
138 lift $ do
139 rec (result0, result') <- base f' loweredDm0 loweredDm'
140 let voidResult' = fmapCheap (\_ -> ()) result'
141 let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))
142 return (result0, result')