git.iko.soy/reflex
on travis-testing help sign in
reflex/test/GC.hs
101 lines 3.8 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TypeFamilies #-}
7module Main where
9import Control.Monad
10import Control.Monad.IO.Class
11import Control.Monad.Ref
12import Data.Align
13import Data.Dependent.Map (DMap)
14import qualified Data.Dependent.Map as DMap
15import Data.Dependent.Sum
16import Data.Functor.Identity
17import Data.GADT.Compare
18import Data.IORef
19import Data.Semigroup
20import Data.These
22import Data.Functor.Misc
23import Reflex.Patch
25import qualified Reflex.Host.Class as Host
26import qualified Reflex.Spider.Internal as S
28import System.Exit
29import System.Mem
30import Data.Coerce
32main :: IO ()
33main = do
34 ref <- newIORef Nothing
35 hostPerf ref
36 readIORef ref >>= maybe exitFailure (putStrLn . ("Result " <>) . show)
38hostPerf :: IORef (Maybe Int) -> IO ()
39hostPerf ref = S.runSpiderHost $ do
40 ---- body
41 liftIO $ putStrLn "#creating triggers"
42 (response', responseTrigger) <- Host.newEventWithTriggerRef
43 (eadd', addTriggerRef) <- Host.newEventWithTriggerRef
44 let response = S.unSpiderEvent response'
45 eadd = S.unSpiderEvent eadd'
46 liftIO $ putStrLn "#creating event graph"
47 eventToPerform <- Host.runHostFrame $ do
48 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
49 <- S.SpiderHostFrame
50 $ fmap ( S.mergeG coerce
51 . S.dynamicHold)
52 $ S.hold DMap.empty
53 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained
54 $ (\e -> S.Event $ \sub -> do
55 (s, o) <- S.subscribeAndRead e $ sub
56 { S.subscriberPropagate = S.subscriberPropagate sub
57 }
58 return (s, o))
59 $ runIdentity . runIdentity <$> S.selectG
60 (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
61 (WrapArg Request)
62 return $ alignWith (mergeThese (<>))
63 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
64 liftIO $ putStrLn "#eadd fired"
65 return $ PatchDMap $ DMap.singleton (Const2 (1 :: Int)) $ ComposeMaybe $ Just
66 $ S.pushCheap (return . Just . DMap.singleton Action . (\_ -> liftIO (writeIORef ref (Just 1)))) $ eadd)
67 (flip S.pushCheap reqMap $ \m -> return $ Just $ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m)
68 ---- epilogue
69 eventToPerformHandle <- Host.subscribeEvent (S.SpiderEvent eventToPerform)
70 liftIO $ putStrLn "#performing GC" >> performMajorGC
71 liftIO $ putStrLn "#attempting to fire eadd"
72 mAddTrigger <- readRef addTriggerRef
73 forM_ mAddTrigger $ \t -> replicateM_ 2 $ do
74 liftIO $ putStrLn "#firing eadd"
75 mToPerform <- Host.fireEventsAndRead [t :=> Identity ()] $ sequence =<< Host.readEvent eventToPerformHandle
76 case mToPerform of
77 Nothing -> return ()
78 Just toPerform -> do
79 responses <- Host.runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform
80 mrt <- readRef responseTrigger
81 let followupEventTriggers = case mrt of
82 Just rt -> [rt :=> Identity responses]
83 Nothing -> []
84 Host.fireEventsAndRead followupEventTriggers $ return ()
85 return ()
86 return ()
88data Tell a where
89 Action :: Tell ()
90 Request :: Tell (PatchDMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) (S.Event S.Global))
92instance GEq Tell where
93 geq Action Action = Just Refl
94 geq Request Request = Just Refl
95 geq _ _ = Nothing
97instance GCompare Tell where
98 gcompare Action Action = GEQ
99 gcompare Request Request = GEQ
100 gcompare Action Request = GLT
101 gcompare Request Action = GGT