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