@@ -1,33 +1,66 @@
11{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
23module Test.Run where
34
45import Control.Monad
56import Control.Monad.Ref
67import Data.Dependent.Sum
78import Data.Functor.Identity
9+import Data.These
810
911import Reflex
1012import Reflex.Host.Class
1113
12−runApp :: (Show a, t ~ SpiderTimeline Global, m ~ SpiderHost Global)
13− => (Event t () -> PerformEventT t m (Maybe (Ref m (Maybe (EventTrigger t ()))), Event t a))
14− -> IO (Maybe a, Maybe (a, a))
15−runApp x = runSpiderHost $ do
16− (pulseE, pulseTriggerRef) <- newEventWithTriggerRef
17− ((mactuateRef, e), FireCommand fire) <- hostPerformEventT $ x pulseE
18− hnd <- subscribeEvent e
19− out1 <- fireEventRefAndRead pulseTriggerRef () hnd
20− out2 <- fmap join $ forM mactuateRef $ \actuateRef -> do
21− let readPhase = do
22− mGetValue <- readEvent hnd
23− case mGetValue of
24− Nothing -> return Nothing
25− Just getValue -> fmap Just getValue
26− mactuate <- readRef actuateRef
27− mpulse <- readRef pulseTriggerRef
28− forM ((,) <$> mactuate <*> mpulse) $ \(actuate, pulse) -> do
29− _ <- fire [actuate :=> Identity ()] $ return ()
30− [Just a] <- fire [pulse :=> Identity ()] $ readPhase
31− [Just b, Nothing] <- fire [actuate :=> Identity (), pulse :=> Identity ()] $ readPhase
32− return (a,b)
33− return (out1, out2)
14+data AppIn t b e = AppIn
15+ { _appIn_behavior :: Behavior t b
16+ , _appIn_event :: Event t e
17+ }
18+
19+data AppOut t b e = AppOut
20+ { _appOut_behavior :: Behavior t b
21+ , _appOut_event :: Event t e
22+ }
23+
24+runApp :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
25+ => (AppIn t bIn eIn -> PerformEventT t m (AppOut t bOut eOut))
26+ -> bIn
27+ -> [Maybe (These bIn eIn)]
28+ -> IO [[(bOut, Maybe eOut)]]
29+runApp app b0 input = runSpiderHost $ do
30+ (appInHoldE, pulseHoldTriggerRef) <- newEventWithTriggerRef
31+ (appInE, pulseEventTriggerRef) <- newEventWithTriggerRef
32+ appInB <- hold b0 appInHoldE
33+ (out, FireCommand fire) <- hostPerformEventT $ app $ AppIn
34+ { _appIn_event = appInE
35+ , _appIn_behavior = appInB
36+ }
37+ hnd <- subscribeEvent (_appOut_event out)
38+ mpulseB <- readRef pulseHoldTriggerRef
39+ mpulseE <- readRef pulseEventTriggerRef
40+ let readPhase = do
41+ b <- sample (_appOut_behavior out)
42+ frames <- sequence =<< readEvent hnd
43+ return (b, frames)
44+ forM input $ \case
45+ Nothing ->
46+ fire [] $ readPhase
47+ Just i -> case i of
48+ This b' -> case mpulseB of
49+ Nothing -> error "tried to fire in-behavior but ref was empty"
50+ Just pulseB -> fire [ pulseB :=> Identity b' ] $ readPhase
51+ That e' -> case mpulseE of
52+ Nothing -> error "tried to fire in-event but ref was empty"
53+ Just pulseE -> fire [ pulseE :=> Identity e' ] $ readPhase
54+ These b' e' -> case mpulseB of
55+ Nothing -> error "tried to fire in-behavior but ref was empty"
56+ Just pulseB -> case mpulseE of
57+ Nothing -> error "tried to fire in-event but ref was empty"
58+ Just pulseE -> fire [ pulseB :=> Identity b', pulseE :=> Identity e' ] $ readPhase
59+
60+runApp' :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
61+ => (Event t eIn -> PerformEventT t m (Event t eOut))
62+ -> [Maybe eIn]
63+ -> IO [[Maybe eOut]]
64+runApp' app input = do
65+ let app' = fmap (AppOut (pure ())) . app
66+ map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input)