parser-c 0.3.0

{-# OPTIONS -XPatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  RenderTests.hs (executable)
-- Copyright   :  (c) 2008 Benedikt Huber
-- License     :  BSD-style
-- Maintainer  :  benedikt.huber@gmail.com
--
-- This module renders test results into HTML files, much like pugs smoke tests.
-- We use stylesheets to color cells in the result table.
--
-- If JQuery and its tablesorter plugin is available, it is used.
--
-- Resources used:
--   ../res/style.css
--   ../res/jquery-latest.js ../res/jquery.tablesorter.js [optional]
--
-- TOOD: Display performance in detailled view too (maybe only if differs significantly from the average performance)
-- TODO: Sort the tests. The tablesorter javascript doesn't play nice with the browser's back-button
-----------------------------------------------------------------------------
module Main (main) where
import Control.Monad
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List

import System.IO
import System.Directory (getCurrentDirectory)
import System.Environment (getArgs)
import System.Exit (exitWith,ExitCode(..))
import System.FilePath
import Text.Printf
import Text.XHtml

import Language.C.Test.Framework

-- | read the dat file containing the test-results
readTestRuns :: FilePath -> IO [TestRun]
readTestRuns = liftM (map read . lines) . readFile

-- Summarize a set of test runs
data TestSetResult = TestSetResult
  {
    testSetName :: String,
    allOk         :: Int,
    someFailed    :: Int,
    initErrors    :: Int,
    fatalErrors   :: Int,
    testSummaries :: Map String TestSummary,
    testRuns      :: [TestRun]
  }
initTestSetResult :: String -> [TestRun] -> TestSetResult
initTestSetResult tsname tsruns = TestSetResult { testSetName = tsname,
                                                    allOk = 0, someFailed = 0,
                                                    initErrors = 0, fatalErrors = 0,
                                                    testSummaries = Map.empty, testRuns = tsruns }
executedTests :: TestSetResult -> Int
executedTests tsr = allOk tsr + someFailed tsr
totalTestRuns :: TestSetResult -> Int
totalTestRuns tsr = executedTests tsr + fatalErrors tsr + initErrors tsr

-- Summarizes one specific test in a test suite
data TestSummary = TestSummary
  {
    sTestInfo     :: Test,
    numOk         :: Int,
    numFailed     :: Int,
    totalEntities :: Double,
    totalTime     :: Time
  }
  deriving (Show,Read)

throughput :: TestSummary -> Double
throughput ts = (totalEntities ts)  `per` (totalTime ts)

numTests :: TestSummary -> Int
numTests s = numOk s + numFailed s

initSummary :: Test -> TestSummary
initSummary t = TestSummary { sTestInfo = t, numOk = 0, numFailed = 0, totalEntities = 0, totalTime = 0 }

-- =====================
-- = Compute summaries =
-- =====================

computeSummary :: String -> [TestRun] -> TestSetResult
computeSummary tsname testruns =
  foldr updateSetSummary (initTestSetResult tsname testruns) testruns

updateSetSummary :: TestRun -> TestSetResult -> TestSetResult
updateSetSummary (FatalError _ _) s = s { fatalErrors = fatalErrors s + 1}
updateSetSummary (InitFailure _ _) s = s { initErrors = initErrors s + 1 }
updateSetSummary (TestResults _obj _files results) s =
  updateTestCount (Map.elems results) $
  s { testSummaries = foldr addToSummary (testSummaries s) (Map.elems results) }
  where
    updateTestCount rs  s' | all (isTestOk . testStatus) rs = s' { allOk = allOk s' + 1 }
                           | otherwise                      = s' { someFailed = someFailed s' + 1 }

addToSummary :: TestResult -> Map String TestSummary -> Map String TestSummary
addToSummary (TestResult testinfo _ teststatus) sums
  | (isTestError teststatus) = sums
  | otherwise = Map.alter alterSummary (testName testinfo) sums
  where
    alterSummary Nothing = alterSummary (Just (initSummary testinfo))
    alterSummary (Just s) = Just$
      case teststatus of
        (TestError _msg) -> s
        (TestFailure _msg _report) -> s { numFailed = succ (numFailed s) }
        (TestOk Nothing _report) ->
          s { numOk = succ (numOk s) }
        (TestOk (Just measure) _report) ->
          s { numOk = succ (numOk s),
              totalEntities = totalEntities s + realToFrac (processedEntities measure),
              totalTime = totalTime s + elapsedTime measure }

-- =========
-- = Files =
-- =========

datFile :: String -> FilePath
datFile testname = testname ++ ".dat"

indexFile :: String
indexFile = "index.html"

testSetFile :: TestSetResult -> String
testSetFile tss = (testSetName tss) ++ ".html"
-- ====================
-- = main entry point =
-- ====================

main :: IO ()
main = do
  args <- getArgs
  when (length args < 2) $ do
    hPutStrLn stderr "Usage: ./RenderTests parser-version test-names"
    exitWith (ExitFailure 1)
  (parserVersion : _tests) <- getArgs
  let tests = map takeBaseName _tests
  testruns <- liftM (zip tests) $ mapM (readTestRuns.datFile) tests
  -- make file references relative to the current directory (for publishing)
  pwd <- getCurrentDirectory
  let normalizeFilePath = makeRelative pwd . normalise'

  -- compute summary
  let testresults = map (uncurry computeSummary) testruns
  -- export index file
  writeFile indexFile $
    htmlFile ("Test result overviews") $
      indexContents parserVersion testresults
  -- export detailed file
  forM_ testresults $ \testResult ->
    writeFile (testSetFile testResult) $
      htmlFile ("Test results for "++ testSetName testResult) $
        detailedContents normalizeFilePath testResult

-- | create index.html
indexContents :: String -> [TestSetResult] -> Html
indexContents parserVersion tsresults =
       h1 << "Test results"
  +++  p  << ("Test with Language.C, "++parserVersion)
  +++  h2 << "Overview"
  +++  overviewTable tsresults ! [ identifier "overviewTable", theclass "tablesorter" ]
  +++  h2 << "Test Summaries"
  +++  concatHtml (map testSummary tsresults)
  where
    overviewTable results =
      mkTableWithSummaryRow
        ["test set name","total tests", "init error", "fatal error", "tests run", "all tests ok", "some tests failed" ]
        (map overviewRow results)
        (overviewSummaryRow results)
    overviewRow tsr = (testSetLink tsr) :
                      map (toHtml.show) [totalTestRuns tsr, initErrors tsr, fatalErrors tsr,
                                         executedTests tsr, allOk tsr, someFailed tsr ]
    overviewSummaryRow rs = stringToHtml "Total" :
                            map (toHtml.show)  [ sumMap totalTestRuns rs, sumMap initErrors rs, sumMap fatalErrors rs,
                                                 sumMap executedTests rs, sumMap allOk rs, sumMap someFailed rs]
    sumMap f = sum . map f
    testSetLink tsr = (anchor << testSetName tsr) ! [href (testSetFile tsr)]
    testSummary tsr =
          h3 << (testSetLink tsr)
      +++ summaryView tsr

-- | create testset.html
detailedContents :: (FilePath -> FilePath) -> TestSetResult -> Html
detailedContents normRef tsr =
      (anchor << "Contents") ! [href "index.html"]
  +++ h1 << ("Test Results for " ++ testSetName tsr)
  +++ h2 << "Summary"
  +++ summaryView tsr
  +++ h2 << "Detailed View"
  +++ detailedView normRef tsr

-- ==================
-- = HTML rendering =
-- ==================

mkTable :: (HTML hd) => [hd] -> [[Html]] -> Html
mkTable tableHeader tableRows =
  table $
        thead << (tr << (map (th <<) tableHeader))
    +++ tbody << (concatHtml $ map (tr . concatHtml . map td) tableRows)

mkTableWithSummaryRow :: (HTML hd, HTML lst) => [hd] -> [[Html]] -> [lst] -> Html
mkTableWithSummaryRow tableHeader tableRows tableLast =
  table $
        thead << (tr << (map (th <<) tableHeader))
    +++ tbody << (concatHtml $ map (tr . concatHtml . map td) tableRows)
    +++ tr (concatHtml $ map (\c -> (td << c) ! [ theclass "last_row" ]) tableLast)

tablesorterImport :: [String] -> Html
tablesorterImport tids =
    (script << "") ! [ thetype "text/javascript", src "../res/jquery-latest.js"]
    +++ (script << "") ! [ thetype "text/javascript", src "../res/jquery.tablesorter.js"]
    +++ concatHtml (map (addSort . ('#':)) tids)
    where
       addSort tid = (script <<  primHtml ("$(function() { $(" ++ quoteString tid ++  ").tablesorter({ widgets: ['zebra'] } ); });"))
                     ! [ thetype "text/javascript" ]
       quoteString s = ('"' : s) ++ "\""

htmlFile :: String -> Html -> String
htmlFile reportTitle thebody = prettyHtml $
  header <<
    (
          (thetitle << reportTitle)
      +++ (thelink << "") ! [ rel "stylesheet", href "../res/style.css", thetype "text/css" ]
      +++ tablesorterImport ["reportTable", "overviewTable"] -- hardcoded
    )
  +++ body thebody

-- =====================
-- = Rendering Summary =
-- =====================

-- * Summary of XXX.dat
-- Executed %d out of %d tests
-- Summary-Table
summaryView :: TestSetResult -> Html
summaryView tsr =
      p << (printf "Executed %d out of %d tests"  (length $ filter hasTestResults runs) (length runs) :: String)
  +++  summaryTable (Map.elems $ testSummaries tsr) ! [ identifier ("table_" ++ testSetName tsr) ]
  where
    runs = testRuns tsr


summaryTable :: [TestSummary] -> Html
summaryTable summaries = mkTable tblHeader (map mkRow summaries)
  where
    tblHeader = words "Test Ok Failed InputSize Time Throughput"
    mkRow  = summaryEntries
    summaryEntries ts =
      let testinfo = sTestInfo ts in
      map stringToHtml $
        [
          testName testinfo,
          show$ numOk ts,
          show$ numFailed ts
        ] ++ (if totalTime ts /= 0 then timeSummary testinfo ts else replicate 3 "n/a")
    timeSummary testinfo ts = [
        formatUnitsSafe (totalEntities ts) (preferredScale testinfo) (inputUnit testinfo),
        formatTimeSafe (totalTime ts) (scaleSecs Unit),
        formatUnitsPerSecond (throughput ts) (preferredScale testinfo) (inputUnit testinfo)
      ]

--
-- create HTML for detailled view
detailedView :: (FilePath -> FilePath) -> TestSetResult -> Html
detailedView normRef tsr =
       h1 (toHtml$ "Detailed Report")
  +++  detailedTable (Set.toList allKeys) (testRuns tsr) ! [ identifier "reportTable", theclass "tablesorter" ]
  where
    allKeys = Set.fromList . map (testName . sTestInfo) . Map.elems . testSummaries $ tsr

    detailedTable testkeys runs = table $
            (thead << (detailedHeader ("Test Objective" : "Input Files" : testkeys)))
        +++ (tbody << (aboves $ map (detailedRow testkeys) runs))
    detailedHeader testkeys = besides $ map (th <<) testkeys

    detailedRow _testkeys (FatalError msg args) = cell$ (td fatalErr) ! [ theclass "fatal_error" ]
      where
      fatalErr =      (toHtml $ "Fatal Error: "++show args )
                  +++ thediv (linesToHtml $ lines msg)  ! [ theclass "errmsg_box" ]

    detailedRow _testkeys (InitFailure msg args) = cell$ (td initError) ! [ theclass "init_error" ]
      where
      initError =     (toHtml $ "Fatal Initialization Error on " ++ show args)
                  +++ thediv (linesToHtml $ lines msg) ! [ theclass "errmsg_box" ]

    detailedRow testkeys (TestResults testobject filesUnderTest results) =
      (cell $ td << testobject)
      `beside` (filesCell filesUnderTest)
      `beside` (besides $ map (detailedCell results) testkeys)

    filesCell :: [FilePath] -> HtmlTable
    filesCell = cell . td . concatHtml . map fileref where
      fileref fp = (anchor << takeFileName fp) ! [href $ normRef fp] +++ br

    detailedCell :: (Map.Map String TestResult) -> String -> HtmlTable
    detailedCell results key =
      cell$ case Map.lookup key results of
        Nothing                                        -> td (toHtml "n/a") ! [ theclass "not_avail"]
        Just (TestResult _testinfo _testargs teststatus) -> statusCell teststatus

    statusCell  :: TestStatus -> Html
    statusCell (TestError errMsg)              = (td << errMsg) ! [ theclass "test_error"]
    statusCell (TestFailure errMsg reportfile) = (td << failureCell errMsg reportfile) ! [ theclass "test_fail"]
    statusCell (TestOk measure mResultFile) = (td << okCell measure mResultFile) ! [ theclass "test_ok"]

    failureCell :: String -> Maybe FilePath -> Html
    failureCell errMsg (Just report) = anchor (toHtml "Failure")  ! [href $ normRef report, title errMsg]
    failureCell errMsg Nothing = toHtml $ "Failure: "++errMsg

    okCell :: Maybe PerfMeasure -> Maybe FilePath -> Html
    okCell measure mReport = addRef mReport "Ok " +++ (measureInfo measure) ! [ theclass "time_info" ]
      where addRef Nothing info  = toHtml info
            addRef (Just f) info = (anchor << info) ! [href $ normRef f]
            measureInfo Nothing = noHtml
            measureInfo (Just m) = thespan << formatTimeAuto (elapsedTime m)

-- extended Filepath.normalise
-- we want to have @normalise' "/Foo/./bar/.././../baz"@ ==> @"/baz"@
-- Do not know how to accomplish this with System.FilePath ...
normalise' :: FilePath -> FilePath
normalise' = joinPath . reverse . foldl removeDotDot [] . splitPath . normalise
  where
    removeDotDot (dircomp:ds) dotDot | dropTrailingPathSeparator dotDot == "..", not (isAbsolute dircomp) = ds
    removeDotDot (dircomp:ds) dot    | dropTrailingPathSeparator dot == "." = (dircomp:ds)
    removeDotDot ds c = c:ds