git.iko.soy/reflex
on mb@revert-profiled-changes help sign in
reflex/test/GC.hs
100 lines 3.7 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
31main :: IO ()
32main = do
33 ref <- newIORef Nothing
34 hostPerf ref
35 readIORef ref >>= maybe exitFailure (putStrLn . ("Result " <>) . show)
37hostPerf :: IORef (Maybe Int) -> IO ()
38hostPerf ref = S.runSpiderHost $ do
39 ---- body
40 liftIO $ putStrLn "#creating triggers"
41 (response', responseTrigger) <- Host.newEventWithTriggerRef
42 (eadd', addTriggerRef) <- Host.newEventWithTriggerRef
43 let response = S.unSpiderEvent response'
44 eadd = S.unSpiderEvent eadd'
45 liftIO $ putStrLn "#creating event graph"
46 eventToPerform <- Host.runHostFrame $ do
47 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
48 <- S.SpiderHostFrame
49 $ fmap ( S.merge
50 . S.dynamicHold)
51 $ S.hold DMap.empty
52 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained
53 $ (\e -> S.Event $ \sub -> do
54 (s, o) <- S.subscribeAndRead e $ sub
55 { S.subscriberPropagate = S.subscriberPropagate sub
56 }
57 return (s, o))
58 $ runIdentity <$> S.select
59 (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
60 (WrapArg Request)
61 return $ alignWith (mergeThese (<>))
62 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
63 liftIO $ putStrLn "#eadd fired"
64 return $ PatchDMap $ DMap.singleton (Const2 (1 :: Int)) $ ComposeMaybe $ Just
65 $ S.pushCheap (return . Just . DMap.singleton Action . (\_ -> liftIO (writeIORef ref (Just 1)))) $ eadd)
66 (flip S.pushCheap reqMap $ \m -> return $ Just $ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m)
67 ---- epilogue
68 eventToPerformHandle <- Host.subscribeEvent (S.SpiderEvent eventToPerform)
69 liftIO $ putStrLn "#performing GC" >> performMajorGC
70 liftIO $ putStrLn "#attempting to fire eadd"
71 mAddTrigger <- readRef addTriggerRef
72 forM_ mAddTrigger $ \t -> replicateM_ 2 $ do
73 liftIO $ putStrLn "#firing eadd"
74 mToPerform <- Host.fireEventsAndRead [t :=> Identity ()] $ sequence =<< Host.readEvent eventToPerformHandle
75 case mToPerform of
76 Nothing -> return ()
77 Just toPerform -> do
78 responses <- Host.runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform
79 mrt <- readRef responseTrigger
80 let followupEventTriggers = case mrt of
81 Just rt -> [rt :=> Identity responses]
82 Nothing -> []
83 Host.fireEventsAndRead followupEventTriggers $ return ()
84 return ()
85 return ()
87data Tell a where
88 Action :: Tell ()
89 Request :: Tell (PatchDMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) (S.Event S.Global))
91instance GEq Tell where
92 geq Action Action = Just Refl
93 geq Request Request = Just Refl
94 geq _ _ = Nothing
96instance GCompare Tell where
97 gcompare Action Action = GEQ
98 gcompare Request Request = GEQ
99 gcompare Action Request = GLT
100 gcompare Request Action = GGT