ghc-eventlog-loopback-0.1.0.0: test/Main.hs

{-# LANGUAGE OverloadedStrings #-}
module Main (main) where

import GHC.RTS.Events.Loopback
import Control.Monad
import Debug.Trace
import Data.IORef
import Control.Concurrent
import System.Exit

import GHC.RTS.Events.Incremental
import GHC.RTS.Events (EventInfo(UserMessage), evSpec)


main :: IO ()
main = do
  state <- newIORef decodeEventLog
  events <- newIORef []
  let go bs = do
        s <- readIORef state
        let s' = case s of
                    Consume feed -> feed bs
                    _ -> error "impossible"
        s'' <- produceAll s'
        writeIORef state $! s''
      produceAll (Produce ev k) = modifyIORef' events (ev:) >> produceAll k
      produceAll (Error _ emsg) = error $ "Failed to parse: " ++ emsg
      produceAll k = pure k
  start
  void . forkIO . forever $ readEventLogChunk >>= go
  traceEventIO "foo bar baz"
  flushEventLog
  traceEventIO "foo bar baz"
  flushEventLog
  threadDelay 100
  evs <- readIORef events
  case length . filter (findExpectedMessage . evSpec) $ evs of
    2 -> putStrLn "Success" >> exitSuccess
    x -> do
      putStrLn $ "expected 2 but got " ++ show x
      exitFailure

findExpectedMessage :: EventInfo -> Bool
findExpectedMessage (UserMessage "foo bar baz") = True
findExpectedMessage _ = False