From 54fb845b2b322d823fb44f905bd4c4d40225259c Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 16:03:19 +0200 Subject: Move Haddock runner of HTML test suite to Haddock test package. --- haddock-test/haddock-test.cabal | 1 + haddock-test/src/Test/Haddock.hs | 117 ++++++++++++++++++++++++++++++++++++++ html-test/run.hs | 120 +-------------------------------------- 3 files changed, 120 insertions(+), 118 deletions(-) create mode 100644 haddock-test/src/Test/Haddock.hs diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index aabe12e9..4cf10799 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -19,6 +19,7 @@ library build-depends: base, directory, process, filepath, Cabal, xml, syb exposed-modules: + Test.Haddock Test.Haddock.Config Test.Haddock.Process Test.Haddock.Xhtml 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" diff --git a/html-test/run.hs b/html-test/run.hs index 5a2944f9..48c733d0 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -1,46 +1,14 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -import Control.Applicative -import Control.Monad - -import Data.Maybe -import Data.List - -import System.Console.GetOpt -import System.Directory import System.Environment -import System.Exit import System.FilePath -import System.IO -import System.Process -import qualified Text.XML.Light as Xml +import Test.Haddock -import Test.Haddock.Process -import Test.Haddock.Config -import Test.Haddock.Xhtml - -baseDir, rootDir :: FilePath +baseDir :: FilePath baseDir = takeDirectory __FILE__ -rootDir = baseDir ".." - -srcDir, refDir, outDir :: FilePath -srcDir = baseDir "src" -refDir = baseDir "ref" -outDir = baseDir "out" - -resDir :: FilePath -resDir = rootDir "resources" - - -data CheckResult - = Fail - | Pass - | NoRef main :: IO () @@ -51,90 +19,6 @@ main = do checkFiles cfg -checkFiles :: Config -> IO () -checkFiles (Config { .. }) = do - putStrLn "Testing output files..." - failed <- liftM catMaybes . forM cfgFiles $ \file -> do - let mdl = takeBaseName file - putStr $ "Checking " ++ mdl ++ "... " - - status <- checkModule 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 cfgDiffTool failed - exitFailure - - -maybeDiff :: Maybe FilePath -> [String] -> IO () -maybeDiff Nothing _ = pure () -maybeDiff (Just diff) mdls = do - putStrLn "Diffing failed cases..." - forM_ mdls $ diffModule 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 :: String -> IO CheckResult -checkModule mdl = do - hasRef <- doesFileExist $ refFile mdl - if hasRef - then do - Just outXml <- readXml $ outFile mdl - Just refXml <- readXml $ refFile mdl - return $ if strip outXml == strip refXml - then Pass - else Fail - else return NoRef - - -diffModule :: FilePath -> String -> IO () -diffModule diff mdl = do - Just outXml <- readXml $ outFile mdl - Just refXml <- readXml $ refFile 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 - outFile' = outFile mdl <.> "nolinks" - refFile' = outFile mdl <.> "ref" <.> "nolinks" - - -outFile :: String -> FilePath -outFile mdl = outDir mdl <.> "html" - - -refFile :: String -> FilePath -refFile mdl = refDir mdl <.> "html" - - -- *** OLD TEST RUNNER UTILITY FUNCTIONS *** -- These are considered bad and should be replaced as soon as possible. -- cgit v1.2.3