hunit-gui (empty) → 0.1

raw patch · 11 files changed

+294/−0 lines, 11 filesdep +HUnitdep +basedep +cairosetup-changed

Dependencies added: HUnit, base, cairo, gtk

Files

• Setup.hs +14/−0
• Test/HUnit/Gui.hs +4/−0
• Test/HUnit/Gui/Bar.hs +53/−0
• Test/HUnit/Gui/BarComputations.hs +8/−0
• Test/HUnit/Gui/Descriptions.hs +19/−0
• Test/HUnit/Gui/Runner.hs +29/−0
• Test/HUnit/Gui/Status.hs +12/−0
• Test/HUnit/Gui/Window.hs +70/−0
• examples/Main.hs +26/−0
• hunit-gui.cabal +42/−0
• tests/AllTests.hs +17/−0

@@ -0,0 +1,14 @@+import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import System.Cmd+import System.Exit+++main :: IO ()+main = defaultMainWithHooks (simpleUserHooks { runTests = runAllTests })++runAllTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+runAllTests _ _ _ _ = do+  code <- system "./dist/build/tests/tests"+  exitWith code

@@ -0,0 +1,4 @@+module Test.HUnit.Gui (runTestGui, exitWhenGuiCloses)+where++import Test.HUnit.Gui.Window

@@ -0,0 +1,53 @@+module Test.HUnit.Gui.Bar (Bar, createBar, changeBar)+where++import Control.Concurrent.MVar+import Graphics.Rendering.Cairo (liftIO, Render, setSourceRGB, rectangle, fill)+import Graphics.UI.Gtk hiding (fill)+import Graphics.UI.Gtk.Gdk.EventM+import Test.HUnit.Base++import Test.HUnit.Gui.BarComputations+import Test.HUnit.Gui.Status++data Bar = Bar DrawingArea (MVar Counts)++createBar :: (DrawingArea -> IO ()) -> IO Bar+createBar addToContainer =+    do+      drawingArea <- drawingAreaNew+      counts' <- newMVar emptyCounts+      let bar = Bar drawingArea counts'+      drawingArea `on` exposeEvent $ redrawBar bar+      widgetSetSizeRequest drawingArea 100 20+      addToContainer drawingArea+      return bar+    where+      emptyCounts = Counts 1 0 0 0++redrawBar :: Bar -> EventM EExpose Bool+redrawBar (Bar _ countsRef) = do+  window <- eventWindow+  liftIO $ do+    counts' <- readMVar countsRef+    (width, height) <- drawableGetSize window+    renderWithDrawable window $ drawBar counts' width height+    return True++changeBar :: Bar -> Counts -> IO ()+changeBar (Bar drawingArea countsRef) newCounts = do+  modifyMVar_ countsRef (\_ -> return newCounts)+  widgetQueueResize drawingArea++drawBar :: Counts -> Int -> Int -> Render()+drawBar counts' width height = do+  uncurry3 setSourceRGB $ colorForStatus $ succeeded counts'+  rectangle 0 0 (barWidth counts' width) (fromIntegral height)+  fill++colorForStatus :: Status -> (Double, Double, Double)+colorForStatus Red = (1, 0, 0)+colorForStatus Green = (0, 1, 0)++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (x, y, z) = f x y z

@@ -0,0 +1,8 @@+module Test.HUnit.Gui.BarComputations (barWidth)+where++import Test.HUnit.Base++barWidth :: Counts -> Int -> Double+barWidth counts' totalWidth =+    (fromIntegral totalWidth) * (fromIntegral $ tried counts') / (fromIntegral $ cases counts')

@@ -0,0 +1,19 @@+module Test.HUnit.Gui.Descriptions (describeError, describeFailure)+where++import Test.HUnit.Base+import Test.HUnit.Text (showPath)++describeError :: String -> State -> String+describeError = describeProblem++describeFailure :: String -> State -> String+describeFailure = describeProblem++describeProblem :: String -> State -> String+describeProblem msg state =+    let path' = path state+    in if null path'+       then msg+       else (showPath path') ++ ":\n" ++ msg+

@@ -0,0 +1,29 @@+module Test.HUnit.Gui.Runner (GuiInterface(..), runTests)+where++import Test.HUnit++import Test.HUnit.Gui.Descriptions++data GuiInterface = GuiInterface (String -> IO ()) (String -> IO ()) (Counts -> IO ())++runTests :: GuiInterface -> Test -> IO Counts+runTests (GuiInterface updateTestsRun updateFailureDetails updateTestBar) tests = do+  (counts', _) <- performTest reportStart reportErrors reportFailures GuiUpdater tests+  updateTestsRun $ showCounts counts'+  return counts'+    where+      reportStart state _ = do+        updateTestsRun $ show $ counts state+        updateTestBar $ counts state+        return GuiUpdater+      reportErrors msg state _ = reportErrorsFailures (describeError msg state) state+      reportFailures msg state _ = reportErrorsFailures (describeFailure msg state) state+      reportErrorsFailures msg state = do+        updateTestBar $ counts state+        updateFailureDetails msg+        return GuiUpdater++-- trivial "state" token+data GuiUpdater = GuiUpdater+

@@ -0,0 +1,12 @@+module Test.HUnit.Gui.Status (Status(..), succeeded)+where++import Test.HUnit.Base++data Status = Red+            | Green+              deriving (Show, Eq)++succeeded :: Counts -> Status+succeeded (Counts { errors = 0, failures = 0 }) = Green+succeeded _ = Red

@@ -0,0 +1,70 @@+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)+

@@ -0,0 +1,26 @@+module Main+where++import Test.HUnit+import Test.HUnit.Gui++main = do+  testInfo <- runTestGui bigLongTests+  exitWhenGuiCloses testInfo++-- First and third tests should pass; second and fourth should fail+bigLongTests :: Test+bigLongTests = test [ "first" ~: 224743 ~=? (head $ drop 20000 primes)+                    , "second" ~: 22 ~=? (head $ drop 40000 primes)+                    , "third" ~: 746777 ~=? (head $ drop 60000 primes)+                    , "fourth" ~: 44 ~=? (head $ drop 80000 primes)+                    ]+    where+      odds = [3,5..] :: [Integer]+      primeToList n = not . any (\p -> n `mod` p == 0)+      primes =+          let aux [] = []+              aux ns@(p:_) =+                  let (knownPrimes, remaining) = span (\n -> n < p*p) ns+                  in knownPrimes ++ (aux $ filter (\n -> primeToList n knownPrimes) remaining)+          in 2 : (aux odds)

@@ -0,0 +1,42 @@+Name:           hunit-gui+Version:        0.1+Cabal-Version:  >= 1.6+License:        PublicDomain+Author:         Kim Wallmark+Homepage:       http://patch-tag.com/r/kwallmar/hunit_gui/home+Category:       Testing+Synopsis:       A GUI testrunner for HUnit+Build-Type:     Simple+Data-Files:     examples/Main.hs+Maintainer:	kim_hunitgui@arlim.org+Description:+    hunit-gui is a graphical front-end for HUnit.  It provides a test+    controller you can use in place of runTestTT or runTestText, as well+    as an optional cleanup step.++Library+  Exposed-modules:+    Test.HUnit.Gui,+    Test.HUnit.Gui.Bar,+    Test.HUnit.Gui.BarComputations,+    Test.HUnit.Gui.Descriptions,+    Test.HUnit.Gui.Runner,+    Test.HUnit.Gui.Status,+    Test.HUnit.Gui.Window+  Hs-Source-Dirs:   .+  Build-Depends:+    base == 3.*,+    HUnit == 1.2.*,+    gtk == 0.10.*,+    cairo == 0.10.*+  Ghc-Options:      -Wall++Executable tests+  Main-Is:           AllTests.hs+  Hs-Source-Dirs:    . tests+  Build-Depends:+    base == 3.*,+    HUnit == 1.2.*,+    gtk == 0.10.*,+    cairo == 0.10.*+  Ghc-Options:       -Wall

@@ -0,0 +1,17 @@+module Main (main)+where++import Test.HUnit+import Test.HUnit.Gui++import qualified BarComputationsTests+import qualified DescriptionsTests+import qualified StatusTests++main :: IO ()+main = do+  testInfo <- runTestGui $ test [ StatusTests.tests+                               , DescriptionsTests.tests+                               , BarComputationsTests.tests+                               ]+  exitWhenGuiCloses testInfo