Window.hs

module Test.HUnit.Gui.Window (runTestGui, exitWhenGuiCloses)
where

import Control.Concurrent
import Graphics.UI.Gtk
import System.Exit
import Test.HUnit

import Test.HUnit.Gui.Bar
import Test.HUnit.Gui.Runner
import Test.HUnit.Gui.Status

runTestGui :: Test -> IO (Counts, ThreadId)
runTestGui tests = do
  guiInterfaceVar <- newEmptyMVar
  guiThread <- forkIO $ runGui guiInterfaceVar
  guiInterface <- takeMVar guiInterfaceVar
  putStrLn "Close the GUI window to end the test session"
  counts' <- runTests guiInterface tests
  return (counts', guiThread)

exitWhenGuiCloses :: (Counts, ThreadId) -> IO ()
exitWhenGuiCloses (counts', guiThread) = do
  waitForGuiToClose guiThread
  exitWithProperStatusCode
      where
        exitWithProperStatusCode = exitWith $ statusCodeFor $ succeeded counts'
        statusCodeFor Green = ExitSuccess
        statusCodeFor Red = ExitFailure 2

waitForGuiToClose :: ThreadId -> IO ()
waitForGuiToClose guiThread = do
  killThread guiThread

runGui :: MVar GuiInterface -> IO ()
runGui guiInterfaceVar = do
  initGUI
  window <- windowNew
  onDestroy window mainQuit

  container <- vBoxNew False 20
  set window [ containerChild := container ]
  set window [ containerBorderWidth := 30 ]

  testsRun <- labelNew $ Just "--"
  containerAdd container testsRun

  failureDetails <- labelNew $ Nothing
  containerAdd container failureDetails

  bar <- createBar (containerAdd container)

  widgetShowAll window
  idleAdd (do yield
              return True) priorityDefaultIdle

  putMVar guiInterfaceVar (GuiInterface
                           (labelSetText testsRun)
                           (labelAppendText failureDetails)
                           (changeBar bar))

  mainGUI

labelAppendText :: Label -> String -> IO ()
labelAppendText label str =
    do
      text <- labelGetText label
      labelSetText label (case text of "" -> str
                                       _ -> text ++ "\n\n" ++ str)