@@ -0,0 +1,112 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+
7+module Reflex.TriggerEvent.Base where
8+
9+import Control.Concurrent
10+import Control.Monad.Exception
11+import Control.Monad.Reader
12+import Control.Monad.Ref
13+import Data.Dependent.Sum
14+import Reflex.Class
15+import Reflex.Host.Class
16+import Reflex.PerformEvent.Base
17+import Reflex.PerformEvent.Class
18+import Reflex.PostBuild.Class
19+import Reflex.TriggerEvent.Class
20+
21+data TriggerInvocation a = TriggerInvocation a (IO ())
22+
23+newtype TriggerEventT t m a = TriggerEventT
24+ { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t m) TriggerInvocation]) m a
25+ } deriving ( Functor
26+ , Applicative
27+ , Monad
28+ , MonadFix
29+ , MonadIO
30+ , MonadException
31+ , MonadAsyncException
32+ )
33+
34+runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t m) TriggerInvocation] -> m a
35+runTriggerEventT = runReaderT . unTriggerEventT
36+
37+instance MonadTrans (TriggerEventT t) where
38+ lift = TriggerEventT . lift
39+
40+instance PerformEvent t m =>
41+ PerformEvent t (TriggerEventT t m) where
42+ type Performable (TriggerEventT t m) = Performable m
43+ performEvent_ e = lift $ performEvent_ e
44+ {-# INLINABLE performEvent_ #-}
45+ performEvent e = lift $ performEvent e
46+ {-# INLINABLE performEvent #-}
47+
48+instance PostBuild t m =>
49+ PostBuild t (TriggerEventT t m) where
50+ getPostBuild = lift getPostBuild
51+ {-# INLINABLE getPostBuild #-}
52+
53+instance MonadReflexCreateTrigger t m =>
54+ MonadReflexCreateTrigger t (TriggerEventT t m) where
55+ newEventWithTrigger = lift . newEventWithTrigger
56+ {-# INLINABLE newEventWithTrigger #-}
57+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
58+ {-# INLINABLE newFanEventWithTrigger #-}
59+
60+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) =>
61+ TriggerEvent t (TriggerEventT t m) where
62+ newTriggerEvent = do
63+ (e, t) <- newTriggerEventWithOnComplete
64+ return (e, \a -> t a $ return ())
65+ {-# INLINABLE newTriggerEvent #-}
66+ newTriggerEventWithOnComplete = do
67+ events <- askEvents
68+ (eResult, reResultTrigger) <- lift newEventWithTriggerRef
69+ return . (,) eResult $ \a cb ->
70+ writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
71+ {-# INLINABLE newTriggerEventWithOnComplete #-}
72+ newEventWithLazyTriggerWithOnComplete f = do
73+ events <- askEvents
74+ lift . newEventWithTrigger $ \t ->
75+ f $ \a cb -> do
76+ reResultTrigger <- newRef $ Just t
77+ writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
78+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
79+
80+instance MonadRef m =>
81+ MonadRef (TriggerEventT t m) where
82+ type Ref (TriggerEventT t m) = Ref m
83+ newRef = lift . newRef
84+ {-# INLINABLE newRef #-}
85+ readRef = lift . readRef
86+ {-# INLINABLE readRef #-}
87+ writeRef r = lift . writeRef r
88+ {-# INLINABLE writeRef #-}
89+
90+instance MonadAtomicRef m =>
91+ MonadAtomicRef (TriggerEventT t m) where
92+ atomicModifyRef r = lift . atomicModifyRef r
93+ {-# INLINABLE atomicModifyRef #-}
94+
95+instance MonadSample t m =>
96+ MonadSample t (TriggerEventT t m) where
97+ sample = lift . sample
98+ {-# INLINABLE sample #-}
99+
100+instance MonadHold t m =>
101+ MonadHold t (TriggerEventT t m) where
102+ hold v0 v' = lift $ hold v0 v'
103+ {-# INLINABLE hold #-}
104+ holdDyn v0 v' = lift $ holdDyn v0 v'
105+ {-# INLINABLE holdDyn #-}
106+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
107+ {-# INLINABLE holdIncremental #-}
108+
109+askEvents
110+ :: Monad m
111+ => TriggerEventT t m (Chan [DSum (EventTriggerRef t m) TriggerInvocation])
112+askEvents = TriggerEventT ask