diff options
author | Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com> | 2015-08-13 16:03:19 +0200 |
---|---|---|
committer | Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com> | 2015-08-22 23:40:27 +0200 |
commit | 54fb845b2b322d823fb44f905bd4c4d40225259c (patch) | |
tree | 28817b0d3f1024ff5da784b2a7c5e51fabad189c /haddock-test/src | |
parent | fa04b4138311db1026755e3d75fdd4abaa81c427 (diff) |
Move Haddock runner of HTML test suite to Haddock test package.
Diffstat (limited to 'haddock-test/src')
-rw-r--r-- | haddock-test/src/Test/Haddock.hs | 117 |
1 files changed, 117 insertions, 0 deletions
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs new file mode 100644 index 00000000..6ca57d7b --- /dev/null +++ b/haddock-test/src/Test/Haddock.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Test.Haddock + ( module Test.Haddock + , module Test.Haddock.Config + ) where + + +import Control.Monad + +import Data.Maybe + +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process + +import Test.Haddock.Config +import Test.Haddock.Process +import Test.Haddock.Xhtml + +import qualified Text.XML.Light as Xml + + +data CheckResult + = Fail + | Pass + | NoRef + + +checkFiles :: Config -> IO () +checkFiles cfg@(Config { .. }) = do + putStrLn "Testing output files..." + failed <- liftM catMaybes . forM cfgFiles $ \file -> do + let mdl = takeBaseName file + putStr $ "Checking " ++ mdl ++ "... " + + status <- checkModule cfg mdl + case status of + Fail -> putStrLn "FAIL" >> (return $ Just mdl) + Pass -> putStrLn "PASS" >> (return Nothing) + NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing) + + if null failed + then do + putStrLn "All tests passed!" + exitSuccess + else do + maybeDiff cfg failed + exitFailure + + +maybeDiff :: Config -> [String] -> IO () +maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure () +maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) mdls = do + putStrLn "Diffing failed cases..." + forM_ mdls $ diffModule cfg diff + + +runHaddock :: Config -> IO () +runHaddock (Config { .. }) = do + putStrLn "Running Haddock process..." + + haddockStdOut <- openFile cfgHaddockStdOut WriteMode + handle <- runProcess' cfgHaddockPath $ processConfig + { pcArgs = cfgHaddockArgs ++ cfgFiles + , pcEnv = Just $ cfgEnv + , pcStdOut = Just $ haddockStdOut + } + waitForSuccess "Failed to run Haddock on specified test files" handle + + +checkModule :: Config -> String -> IO CheckResult +checkModule cfg mdl = do + hasRef <- doesFileExist $ refFile dcfg mdl + if hasRef + then do + Just outXml <- readXml $ outFile dcfg mdl + Just refXml <- readXml $ refFile dcfg mdl + return $ if strip outXml == strip refXml + then Pass + else Fail + else return NoRef + where + dcfg = cfgDirConfig cfg + + +diffModule :: Config -> FilePath -> String -> IO () +diffModule cfg diff mdl = do + Just outXml <- readXml $ outFile dcfg mdl + Just refXml <- readXml $ refFile dcfg mdl + let outXml' = strip outXml + let refXml' = strip refXml + writeFile outFile' $ Xml.ppElement outXml' + writeFile refFile' $ Xml.ppElement refXml' + + putStrLn $ "Diff for module " ++ show mdl ++ ":" + hFlush stdout + handle <- runProcess' diff $ processConfig + { pcArgs = [outFile', refFile'] + , pcStdOut = Just $ stdout + } + waitForProcess handle >> return () + where + dcfg = cfgDirConfig cfg + outFile' = outFile dcfg mdl <.> "nolinks" + refFile' = outFile dcfg mdl <.> "ref" <.> "nolinks" + + +outFile :: DirConfig -> String -> FilePath +outFile dcfg mdl = dcfgOutDir dcfg </> mdl <.> "html" + + +refFile :: DirConfig -> String -> FilePath +refFile dcfg mdl = dcfgRefDir dcfg </> mdl <.> "html" |