git.iko.soy/patch
on 2bb2332 help sign in
patch/src/Reflex/PostBuild/Class.hs
103 lines 4.4 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE RecursiveDo #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE UndecidableInstances #-}
11module Reflex.PostBuild.Class where
13import Control.Monad.Exception
14import Control.Monad.Primitive
15import Control.Monad.Reader
16import Control.Monad.Ref
17import Control.Monad.Trans.Control
18import qualified Data.Dependent.Map as DMap
19import Reflex.Class
20import Reflex.Host.Class
21import Reflex.PerformEvent.Class
23class (Reflex t, Monad m) => PostBuild t m | m -> t where
24 getPostBuild :: m (Event t ())
26newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
28instance PrimMonad m => PrimMonad (PostBuildT x m) where
29 type PrimState (PostBuildT x m) = PrimState m
30 primitive = lift . primitive
32instance MonadTransControl (PostBuildT t) where
33 type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a
34 {-# INLINABLE liftWith #-}
35 liftWith = defaultLiftWith PostBuildT unPostBuildT
36 {-# INLINABLE restoreT #-}
37 restoreT = defaultRestoreT PostBuildT
39instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
40 {-# INLINABLE getPostBuild #-}
41 getPostBuild = PostBuildT ask
43instance MonadSample t m => MonadSample t (PostBuildT t m) where
44 {-# INLINABLE sample #-}
45 sample = lift . sample
47instance MonadHold t m => MonadHold t (PostBuildT t m) where
48 {-# INLINABLE hold #-}
49 hold v0 = lift . hold v0
50 {-# INLINABLE holdDyn #-}
51 holdDyn v0 = lift . holdDyn v0
52 {-# INLINABLE holdIncremental #-}
53 holdIncremental v0 = lift . holdIncremental v0
55instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
56 type Performable (PostBuildT t m) = PostBuildT t (Performable m)
57 {-# INLINABLE performEvent_ #-}
58 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
59 {-# INLINABLE performEvent #-}
60 performEvent e = liftWith $ \run -> performEvent $ fmap run e
62instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
63 {-# INLINABLE newEventWithTrigger #-}
64 newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
65 {-# INLINABLE newFanEventWithTrigger #-}
66 newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
68instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
69 {-# INLINABLE newTriggerEvent #-}
70 newTriggerEvent = lift newTriggerEvent
71 {-# INLINABLE newTriggerEventWithOnComplete #-}
72 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
73 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
75instance MonadRef m => MonadRef (PostBuildT t m) where
76 type Ref (PostBuildT t m) = Ref m
77 {-# INLINABLE newRef #-}
78 newRef = lift . newRef
79 {-# INLINABLE readRef #-}
80 readRef = lift . readRef
81 {-# INLINABLE writeRef #-}
82 writeRef r = lift . writeRef r
84instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
85 {-# INLINABLE atomicModifyRef #-}
86 atomicModifyRef r = lift . atomicModifyRef r
88{-# INLINABLE runPostBuildT #-}
89runPostBuildT :: PostBuildT t m a -> Event t () -> m a
90runPostBuildT (PostBuildT a) = runReaderT a
92instance PostBuild t m => PostBuild t (ReaderT r m) where
93 getPostBuild = lift getPostBuild
95instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where
96 sequenceDMapWithAdjust dm0 dm' = do
97 postBuild <- getPostBuild
98 let loweredDm0 = DMap.map (`runPostBuildT` postBuild) dm0
99 rec (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'
100 delayedResult' <- performEvent $ return () <$ result' -- Delaying this result seems to be faster than making RequestT (and thus PerformEvent) more prompt
101 let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $
102 DMap.map (ComposeMaybe . fmap (\v -> runPostBuildT v =<< headE (void delayedResult')) . 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
103 return (result0, result')