git.iko.soy/reflex
on develop 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
21import Data.Type.Equality ((:~:)(Refl))
23import Data.Functor.Misc
24import Data.Patch
26import qualified Reflex.Host.Class as Host
27import qualified Reflex.Spider.Internal as S
29import System.Exit
30import System.Mem
31import Data.Coerce
33main :: IO ()
34main = do
35 ref <- newIORef Nothing
36 hostPerf ref
37 readIORef ref >>= maybe exitFailure (putStrLn . ("Result " <>) . show)
39hostPerf :: IORef (Maybe Int) -> IO ()
40hostPerf ref = S.runSpiderHost $ do
41 ---- body
42 liftIO $ putStrLn "#creating triggers"
43 (response', responseTrigger) <- Host.newEventWithTriggerRef
44 (eadd', addTriggerRef) <- Host.newEventWithTriggerRef
45 let response = S.unSpiderEvent response'
46 eadd = S.unSpiderEvent eadd'
47 liftIO $ putStrLn "#creating event graph"
48 eventToPerform <- Host.runHostFrame $ do
49 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
50 <- S.SpiderHostFrame
51 $ fmap ( S.mergeG coerce
52 . S.dynamicHold)
53 $ S.hold DMap.empty
54 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained
55 $ (\e -> S.Event $ \sub -> do
56 (s, o) <- S.subscribeAndRead e $ sub
57 { S.subscriberPropagate = S.subscriberPropagate sub
58 }
59 return (s, o))
60 $ runIdentity . runIdentity <$> S.selectG
61 (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
62 (WrapArg Request)
63 return $ alignWith (mergeThese (<>))
64 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
65 liftIO $ putStrLn "#eadd fired"
66 return $ PatchDMap $ DMap.singleton (Const2 (1 :: Int)) $ ComposeMaybe $ Just
67 $ S.pushCheap (return . Just . DMap.singleton Action . (\_ -> liftIO (writeIORef ref (Just 1)))) $ eadd)
68 (flip S.pushCheap reqMap $ \m -> return $ Just $ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m)
69 ---- epilogue
70 eventToPerformHandle <- Host.subscribeEvent (S.SpiderEvent eventToPerform)
71 liftIO $ putStrLn "#performing GC" >> performMajorGC
72 liftIO $ putStrLn "#attempting to fire eadd"
73 mAddTrigger <- readRef addTriggerRef
74 forM_ mAddTrigger $ \t -> replicateM_ 2 $ do
75 liftIO $ putStrLn "#firing eadd"
76 mToPerform <- Host.fireEventsAndRead [t :=> Identity ()] $ sequence =<< Host.readEvent eventToPerformHandle
77 case mToPerform of
78 Nothing -> return ()
79 Just toPerform -> do
80 responses <- Host.runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform
81 mrt <- readRef responseTrigger
82 let followupEventTriggers = case mrt of
83 Just rt -> [rt :=> Identity responses]
84 Nothing -> []
85 Host.fireEventsAndRead followupEventTriggers $ 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