git.iko.soy/patch
on dc90dd9 help sign in
patch/src/Reflex/PostBuild/Base.hs
119 lines 4.9 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 RecursiveDo #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeOperators #-}
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 ) where
21import Reflex.Class
22import Reflex.Host.Class
23import Reflex.PerformEvent.Class
24import Reflex.PostBuild.Class
25import Reflex.TriggerEvent.Class
27import Control.Monad.Exception
28import Control.Monad.Primitive
29import Control.Monad.Reader
30import Control.Monad.Ref
31import Control.Monad.Trans.Control
32import qualified Data.Dependent.Map as DMap
34-- | Provides a basic implementation of 'PostBuild'.
35newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
37-- | Run a 'PostBuildT' action. An 'Event' should be provided that fires
38-- immediately after the action is finished running; no other 'Event's should
39-- fire first.
40{-# INLINABLE runPostBuildT #-}
41runPostBuildT :: PostBuildT t m a -> Event t () -> m a
42runPostBuildT (PostBuildT a) = runReaderT a
44instance PrimMonad m => PrimMonad (PostBuildT x m) where
45 type PrimState (PostBuildT x m) = PrimState m
46 primitive = lift . primitive
48instance MonadTransControl (PostBuildT t) where
49 type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a
50 {-# INLINABLE liftWith #-}
51 liftWith = defaultLiftWith PostBuildT unPostBuildT
52 {-# INLINABLE restoreT #-}
53 restoreT = defaultRestoreT PostBuildT
55instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
56 {-# INLINABLE getPostBuild #-}
57 getPostBuild = PostBuildT ask
59instance MonadSample t m => MonadSample t (PostBuildT t m) where
60 {-# INLINABLE sample #-}
61 sample = lift . sample
63instance MonadHold t m => MonadHold t (PostBuildT t m) where
64 {-# INLINABLE hold #-}
65 hold v0 = lift . hold v0
66 {-# INLINABLE holdDyn #-}
67 holdDyn v0 = lift . holdDyn v0
68 {-# INLINABLE holdIncremental #-}
69 holdIncremental v0 = lift . holdIncremental v0
71instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
72 type Performable (PostBuildT t m) = PostBuildT t (Performable m)
73 {-# INLINABLE performEvent_ #-}
74 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
75 {-# INLINABLE performEvent #-}
76 performEvent e = liftWith $ \run -> performEvent $ fmap run e
78instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
79 {-# INLINABLE newEventWithTrigger #-}
80 newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
81 {-# INLINABLE newFanEventWithTrigger #-}
82 newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
84instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
85 {-# INLINABLE newTriggerEvent #-}
86 newTriggerEvent = lift newTriggerEvent
87 {-# INLINABLE newTriggerEventWithOnComplete #-}
88 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
89 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
91instance MonadRef m => MonadRef (PostBuildT t m) where
92 type Ref (PostBuildT t m) = Ref m
93 {-# INLINABLE newRef #-}
94 newRef = lift . newRef
95 {-# INLINABLE readRef #-}
96 readRef = lift . readRef
97 {-# INLINABLE writeRef #-}
98 writeRef r = lift . writeRef r
100instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
101 {-# INLINABLE atomicModifyRef #-}
102 atomicModifyRef r = lift . atomicModifyRef r
104instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where
105 runWithReplace a0 a' = do
106 postBuild <- getPostBuild
107 lift $ do
108 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
109 let voidResult' = fmapCheap (\_ -> ()) result'
110 return result
111 sequenceDMapWithAdjust dm0 dm' = do
112 postBuild <- getPostBuild
113 let loweredDm0 = DMap.map (`runPostBuildT` postBuild) dm0
114 lift $ do
115 rec (result0, result') <- sequenceDMapWithAdjust loweredDm0 loweredDm'
116 let voidResult' = fmapCheap (\_ -> ()) result'
117 let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
118 DMap.map (ComposeMaybe . fmap (\v -> runPostBuildT v =<< headE voidResult') . getComposeMaybe) p --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
119 return (result0, result')