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