git.iko.soy/reflex
on ae@dev-script help sign in
reflex/test/Test/Run.hs
74 lines 2.6 kB history raw
1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE LambdaCase #-}
3module Test.Run where
5import Control.Monad
6import Control.Monad.Ref
7import Data.Dependent.Sum
8import Data.Functor.Identity
9import Data.These
11import Reflex
12import Reflex.Host.Class
14data AppIn t b e = AppIn
15 { _appIn_behavior :: Behavior t b
16 , _appIn_event :: Event t e
17 }
19data AppOut t b e = AppOut
20 { _appOut_behavior :: Behavior t b
21 , _appOut_event :: Event t e
22 }
24runApp :: (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)]]
29runApp 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
60runApp' :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
61 => (Event t eIn -> PerformEventT t m (Event t eOut))
62 -> [Maybe eIn]
63 -> IO [[Maybe eOut]]
64runApp' app input = do
65 let app' = fmap (AppOut (pure ())) . app
66 map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input)
68runAppB :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
69 => (Event t eIn -> PerformEventT t m (Behavior t bOut))
70 -> [Maybe eIn]
71 -> IO [[bOut]]
72runAppB app input = do
73 let app' = fmap (flip AppOut never) . app
74 map (map fst) <$> runApp (app' . _appIn_event) () (map (fmap That) input)