@@ -0,0 +1,81 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE ConstraintKinds #-}
6+
7+module Reflex.Host.Headless where
8+
9+import Data.Maybe
10+import Reflex
11+import Control.Monad.Fix
12+import Control.Monad.Primitive
13+import Reflex.Host.Class
14+import Control.Monad.IO.Class
15+import Control.Monad.Ref
16+import Data.IORef
17+import Data.Dependent.Sum
18+import Control.Concurrent.Chan (newChan, readChan)
19+import Control.Monad (forM, forM_)
20+import Control.Monad.Identity (Identity(..))
21+
22+type MonadHeadlessApp t m =
23+ ( Reflex t
24+ , MonadHold t m
25+ , MonadFix m
26+ , PrimMonad (HostFrame t)
27+ , ReflexHost t
28+ , MonadIO (HostFrame t)
29+ , Ref m ~ IORef
30+ , Ref (HostFrame t) ~ IORef
31+ , MonadRef (HostFrame t)
32+ , NotReady t m
33+ , TriggerEvent t m
34+ , PostBuild t m
35+ , PerformEvent t m
36+ , MonadIO m
37+ , MonadIO (Performable m)
38+ , Adjustable t m
39+ )
40+
41+runHeadlessApp
42+ :: (forall t m. MonadHeadlessApp t m => m (Event t ()))
43+ -> IO ()
44+runHeadlessApp guest =
45+ (runSpiderHost :: SpiderHost Global a -> IO a) $ do
46+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
47+ events <- liftIO newChan
48+ (result, fc@(FireCommand fire)) <- do
49+ hostPerformEventT $
50+ flip runPostBuildT postBuild $
51+ flip runTriggerEventT events $
52+ guest
53+ mPostBuildTrigger <- readRef postBuildTriggerRef
54+ forM_ mPostBuildTrigger $ \postBuildTrigger ->
55+ fire [postBuildTrigger :=> Identity ()] $ return ()
56+ shutdown <- subscribeEvent result
57+ fix $ \loop -> do
58+ ers <- liftIO $ readChan events
59+ stop <- fireEventTriggerRefs fc ers $ readEvent shutdown >>= \case
60+ Nothing -> return False
61+ Just _ -> return True
62+ if or stop
63+ then return ()
64+ else loop
65+ where
66+ -- | Use the given 'FireCommand' to fire events that have subscribers
67+ -- and call the callback for the 'TriggerInvocation' of each.
68+ fireEventTriggerRefs
69+ :: (MonadIO m)
70+ => FireCommand t m
71+ -> [DSum (EventTriggerRef t) TriggerInvocation]
72+ -> ReadPhase m a
73+ -> m [a]
74+ fireEventTriggerRefs (FireCommand fire) ers rcb = do
75+ mes <- liftIO $
76+ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
77+ me <- readIORef er
78+ return $ fmap (\e -> e :=> Identity a) me
79+ a <- fire (catMaybes mes) rcb
80+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
81+ return a