git.iko.soy/reflex
on ae@dev-script help sign in
reflex/test/GC.hs
100 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 Data.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 ()
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