@@ -0,0 +1,77 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+
5+module Reflex.Main (runHostWithIO) where
6+
7+import Data.Dependent.Sum (DSum (..) )
8+import Control.Concurrent (Chan, readChan, forkIO, ThreadId)
9+import Reflex.Host.Class
10+import Reflex.PerformEvent.Base
11+import Reflex.PostBuild.Base
12+import Reflex.TriggerEvent.Base
13+import Data.IORef (readIORef)
14+import Control.Monad.Ref (Ref, MonadRef)
15+import Data.Maybe (catMaybes)
16+import Control.Monad.IO.Class
17+import Control.Monad (forever)
18+import Data.Traversable (for)
19+import Data.Foldable (for_)
20+import Data.Functor.Identity
21+
22+type EventChannel t = Chan [DSum (EventTriggerRef t) TriggerInvocation]
23+
24+-- | Run the common PostBuild / PerformEvent stack, spawning a
25+-- background thread consuming events. Takes two interpreters; one for
26+-- the main action, and one for the background events, which may be
27+-- important for applications where OS threads matter.
28+--
29+-- A FireCommand is returned that can be used to fire events manually,
30+-- which will properly cascade for PerformEvent.
31+runHostWithIO
32+ :: forall m t a
33+ . ( Monad m
34+ , MonadSubscribeEvent t m
35+ , MonadReflexHost t m
36+ , MonadRef (HostFrame t)
37+ , MonadRef m
38+ , Ref (HostFrame t) ~ Ref IO
39+ , Ref m ~ Ref IO
40+ , MonadIO m
41+ )
42+ => EventChannel t -- ^ Events to process in the background
43+ -> (forall x. m x -> IO x) -- ^ Interpreter for the main action
44+ -> (forall x. m x -> IO x) -- ^ Interpreter for background events
45+ -> PostBuildT t (PerformEventT t m) a -- ^ Main action
46+ -> IO (a, FireCommand t m, ThreadId)
47+runHostWithIO events runMain runAsync a = do
48+ (a', fc) <- runMain $ do
49+ ((a', postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ do
50+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
51+ a' <- runPostBuildT a postBuild
52+ return (a', postBuildTriggerRef)
53+
54+ mPostBuildTrigger <- liftIO $ readIORef postBuildTriggerRef
55+ for_ mPostBuildTrigger $ \postBuildTrigger ->
56+ fire [postBuildTrigger :=> Identity ()] $ return ()
57+ return (a', fc)
58+
59+ tid <- processAsyncEvents events runAsync fc
60+ return (a', fc, tid)
61+
62+processAsyncEvents
63+ :: (MonadSubscribeEvent t m, MonadReflexHost t m, MonadIO m)
64+ => EventChannel t
65+ -> (forall x. m x -> IO x)
66+ -> FireCommand t m
67+ -> IO ThreadId
68+processAsyncEvents events run (FireCommand fire) = forkIO $ forever $ do
69+ ers <- readChan events
70+ _ <- run $ do
71+ mes <-
72+ liftIO $ for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
73+ me <- readIORef er
74+ return $ fmap (\e -> e :=> Identity a) me
75+ _ <- fire (catMaybes mes) $ return ()
76+ liftIO $ for_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
77+ return ()