From 4a4d9ecf66bcb6561f7b10c07742c4b6688332b8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 12:21:45 +0200 Subject: Refactor HTML test suite boilerplate to external package. --- haddock-test/haddock-test.cabal | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 haddock-test/haddock-test.cabal (limited to 'haddock-test/haddock-test.cabal') diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal new file mode 100644 index 00000000..bc0dde6c --- /dev/null +++ b/haddock-test/haddock-test.cabal @@ -0,0 +1,26 @@ +name: haddock-test +version: 0.0.1 +synopsis: Test utilities for Haddock +license: BSD3 +author: Simon Marlow, David Waern +maintainer: Simon Hengel , Mateusz Kowalczyk +homepage: http://www.haskell.org/haddock/ +bug-reports: https://github.com/haskell/haddock/issues +copyright: (c) Simon Marlow, David Waern +category: Documentation +build-type: Simple +cabal-version: >= 1.10 +stability: experimental + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base, directory, process, filepath, Cabal, xml, syb + + exposed-modules: + Test.Haddock.Config + Test.Haddock.Process + Test.Haddock.Xhtml + + other-modules: + Test.Haddock.Utils -- cgit v1.2.3 From fa04b4138311db1026755e3d75fdd4abaa81c427 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 14:34:05 +0200 Subject: Enable all compiler warnings in Haddock test package configuration. --- haddock-test/haddock-test.cabal | 1 + 1 file changed, 1 insertion(+) (limited to 'haddock-test/haddock-test.cabal') diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index bc0dde6c..aabe12e9 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -14,6 +14,7 @@ stability: experimental library default-language: Haskell2010 + ghc-options: -Wall hs-source-dirs: src build-depends: base, directory, process, filepath, Cabal, xml, syb -- cgit v1.2.3 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 (limited to 'haddock-test/haddock-test.cabal') 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 From 188b8aae6efa5d3f41687c84399343494f6bf975 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 21:04:26 +0200 Subject: Adjust module visibility and items they export. --- haddock-test/haddock-test.cabal | 2 +- haddock-test/src/Test/Haddock.hs | 4 ++-- haddock-test/src/Test/Haddock/Config.hs | 7 ++++++- 3 files changed, 9 insertions(+), 4 deletions(-) (limited to 'haddock-test/haddock-test.cabal') diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index 4cf10799..18c9d28b 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -21,8 +21,8 @@ library exposed-modules: Test.Haddock Test.Haddock.Config - Test.Haddock.Process Test.Haddock.Xhtml other-modules: + Test.Haddock.Process Test.Haddock.Utils diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index de293eab..a6b9ea8a 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -2,8 +2,8 @@ module Test.Haddock - ( module Test.Haddock - , module Test.Haddock.Config + ( module Test.Haddock.Config + , runAndCheck, runHaddock, checkFiles ) where diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 3068e52b..0c9bdb19 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -1,7 +1,12 @@ {-# LANGUAGE RecordWildCards #-} -module Test.Haddock.Config where +module Test.Haddock.Config + ( CheckConfig(..), DirConfig(..), Config(..) + , defaultDirConfig + , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir + , parseArgs, checkOpt, loadConfig + ) where import Control.Applicative -- cgit v1.2.3 From 391225eea26bb2484cbf49d0ca5964ab3176b974 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 21 Aug 2015 19:32:37 +0200 Subject: Create helper function for conversion between XML and XHTML. --- haddock-test/haddock-test.cabal | 2 +- haddock-test/src/Test/Haddock/Xhtml.hs | 19 +++++++++++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) (limited to 'haddock-test/haddock-test.cabal') diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index 18c9d28b..0394da8f 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -16,7 +16,7 @@ library default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src - build-depends: base, directory, process, filepath, Cabal, xml, syb + build-depends: base, directory, process, filepath, Cabal, xml, xhtml, syb exposed-modules: Test.Haddock diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index d8c26249..21fda36d 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -13,6 +13,7 @@ import Data.Generics.Aliases import Data.Generics.Schemes import Text.XML.Light +import Text.XHtml newtype Xhtml = Xhtml @@ -72,3 +73,21 @@ stripFooter = [ qName attrKey == "id" , attrVal == "footer" ] + + +xmlElementToXhtml :: Element -> Html +xmlElementToXhtml (Element { .. }) = + tag (qName elName) contents ! attrs + where + contents = mconcat $ map xmlContentToXhtml elContent + attrs = map xmlAttrToXhtml elAttribs + + +xmlContentToXhtml :: Content -> Html +xmlContentToXhtml (Elem el) = xmlElementToXhtml el +xmlContentToXhtml (Text text) = toHtml $ cdData text +xmlContentToXhtml (CRef cref) = noHtml + + +xmlAttrToXhtml :: Attr -> HtmlAttr +xmlAttrToXhtml (Attr { .. }) = strAttr (qName attrKey) attrVal -- cgit v1.2.3