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. --- .gitignore | 1 + haddock-test/haddock-test.cabal | 26 ++++++ haddock-test/src/Test/Haddock/Config.hs | 70 +++++++++++++++ haddock-test/src/Test/Haddock/Process.hs | 49 +++++++++++ haddock-test/src/Test/Haddock/Utils.hs | 8 ++ haddock-test/src/Test/Haddock/Xhtml.hs | 49 +++++++++++ haddock.cabal | 2 +- html-test/run.hs | 145 +------------------------------ 8 files changed, 208 insertions(+), 142 deletions(-) create mode 100644 haddock-test/haddock-test.cabal create mode 100644 haddock-test/src/Test/Haddock/Config.hs create mode 100644 haddock-test/src/Test/Haddock/Process.hs create mode 100644 haddock-test/src/Test/Haddock/Utils.hs create mode 100644 haddock-test/src/Test/Haddock/Xhtml.hs diff --git a/.gitignore b/.gitignore index 3c9798c1..3eb2ed83 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ /dist/ /haddock-api/dist/ /haddock-library/dist/ +/haddock-test/dist/ /html-test/out/ /hypsrc-test/out/ /latex-test/out/ 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 diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs new file mode 100644 index 00000000..bb226fdb --- /dev/null +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -0,0 +1,70 @@ +module Test.Haddock.Config where + + +import System.Console.GetOpt +import System.FilePath + +import Test.Haddock.Process +import Test.Haddock.Utils + + +data Config = Config + { cfgHaddockPath :: FilePath + , cfgGhcPath :: FilePath + , cfgFiles :: [FilePath] + , cfgHaddockArgs :: [String] + , cfgHaddockStdOut :: FilePath + , cfgDiffTool :: Maybe FilePath + , cfgEnv :: Environment + } + + +data Flag + = FlagHaddockPath FilePath + | FlagGhcPath FilePath + | FlagHaddockOptions String + | FlagHaddockStdOut FilePath + | FlagDiffTool FilePath + | FlagNoDiff + | FlagHelp + deriving Eq + + +flagsHaddockPath :: [Flag] -> Maybe FilePath +flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ] + + +flagsGhcPath :: [Flag] -> Maybe FilePath +flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ] + + +flagsHaddockOptions :: [Flag] -> [String] +flagsHaddockOptions flags = concat + [ words opts | FlagHaddockOptions opts <- flags ] + + +flagsHaddockStdOut :: [Flag] -> Maybe FilePath +flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ] + + +flagsDiffTool :: [Flag] -> Maybe FilePath +flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ] + + +options :: [OptDescr Flag] +options = + [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE") + "path to Haddock executable to exectue tests with" + , Option [] ["ghc-path"] (ReqArg FlagGhcPath "FILE") + "path to GHC executable" + , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS") + "additional options to run Haddock with" + , Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE") + "where to redirect Haddock output" + , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH") + "diff tool to use when printing failed cases" + , Option [] ["no-diff"] (NoArg FlagNoDiff) + "do not print diff for failed cases" + , Option ['h'] ["help"] (NoArg FlagHelp) + "display this help end exit" + ] diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs new file mode 100644 index 00000000..97f3ebed --- /dev/null +++ b/haddock-test/src/Test/Haddock/Process.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Test.Haddock.Process where + + +import Control.Monad + +import System.Exit +import System.FilePath +import System.IO +import System.Process + + +type Environment = [(String, String)] + + +data ProcessConfig = ProcessConfig + { pcArgs :: [String] + , pcWorkDir :: Maybe FilePath + , pcEnv :: Maybe Environment + , pcStdIn :: Maybe Handle + , pcStdOut :: Maybe Handle + , pcStdErr :: Maybe Handle + } + + +processConfig :: ProcessConfig +processConfig = ProcessConfig + { pcArgs = [] + , pcWorkDir = Nothing + , pcEnv = Nothing + , pcStdIn = Nothing + , pcStdOut = Nothing + , pcStdErr = Nothing + } + + +runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle +runProcess' path (ProcessConfig { .. }) = runProcess + path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr + + +waitForSuccess :: String -> ProcessHandle -> IO () +waitForSuccess msg handle = do + result <- waitForProcess handle + unless (result == ExitSuccess) $ do + hPutStrLn stderr $ msg + exitFailure diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs new file mode 100644 index 00000000..1d57107f --- /dev/null +++ b/haddock-test/src/Test/Haddock/Utils.hs @@ -0,0 +1,8 @@ +module Test.Haddock.Utils where + + +import Data.Maybe + + +mlast :: [a] -> Maybe a +mlast = listToMaybe . reverse diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs new file mode 100644 index 00000000..35f5910a --- /dev/null +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} + + +module Test.Haddock.Xhtml where + + +import Control.Monad + +import Data.Generics.Aliases +import Data.Generics.Schemes + +import Text.XML.Light + + +deriving instance Eq Content +deriving instance Eq Element +deriving instance Eq CData + + +readXml :: FilePath -> IO (Maybe Element) +readXml = liftM parseXMLDoc . readFile + + +strip :: Element -> Element +strip = stripFooter . stripLinks + + +stripLinks :: Element -> Element +stripLinks = + everywhere (mkT unlink) + where + unlink attr@(Attr { attrKey = key }) + | qName key == "href" = attr { attrVal = "#" } + | otherwise = attr + + +stripFooter :: Element -> Element +stripFooter = + everywhere (mkT defoot) + where + defoot elem + | isFooter elem = elem { elContent = [] } + | otherwise = elem + isFooter elem = any isFooterAttr $ elAttribs elem + isFooterAttr (Attr { .. }) = and + [ qName attrKey == "id" + , attrVal == "footer" + ] diff --git a/haddock.cabal b/haddock.cabal index 40bf59a6..c0e812a1 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -127,7 +127,7 @@ test-suite html-test default-language: Haskell2010 main-is: run.hs hs-source-dirs: html-test - build-depends: base, directory, process, filepath, Cabal, xml, syb + build-depends: base, directory, process, filepath, Cabal, xml, syb, haddock-test test-suite hypsrc-test type: exitcode-stdio-1.0 diff --git a/html-test/run.hs b/html-test/run.hs index f57d547a..e96943a0 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -1,4 +1,3 @@ -#!/usr/bin/env runhaskell {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} @@ -7,8 +6,6 @@ import Control.Applicative import Control.Monad -import Data.Generics.Aliases -import Data.Generics.Schemes import Data.Maybe import Data.List @@ -31,6 +28,10 @@ import System.Process import qualified Text.XML.Light as Xml +import Test.Haddock.Process +import Test.Haddock.Config +import Test.Haddock.Xhtml + baseDir, rootDir :: FilePath baseDir = takeDirectory __FILE__ @@ -45,17 +46,6 @@ resDir :: FilePath resDir = rootDir "resources" -data Config = Config - { cfgHaddockPath :: FilePath - , cfgGhcPath :: FilePath - , cfgFiles :: [FilePath] - , cfgHaddockArgs :: [String] - , cfgHaddockStdOut :: FilePath - , cfgDiffTool :: Maybe FilePath - , cfgEnv :: Environment - } - - data CheckResult = Fail | Pass @@ -262,133 +252,6 @@ modulePath :: String -> FilePath modulePath mdl = srcDir mdl <.> "hs" -deriving instance Eq Xml.Content -deriving instance Eq Xml.Element -deriving instance Eq Xml.CData - - -readXml :: FilePath -> IO (Maybe Xml.Element) -readXml = liftM Xml.parseXMLDoc . readFile - - -strip :: Xml.Element -> Xml.Element -strip = stripFooter . stripLinks - - -stripLinks :: Xml.Element -> Xml.Element -stripLinks = - everywhere (mkT unlink) - where - unlink attr@(Xml.Attr { attrKey = key }) - | Xml.qName key == "href" = attr { Xml.attrVal = "#" } - | otherwise = attr - - -stripFooter :: Xml.Element -> Xml.Element -stripFooter = - everywhere (mkT defoot) - where - defoot elem - | isFooter elem = elem { Xml.elContent = [] } - | otherwise = elem - isFooter elem = any isFooterAttr $ Xml.elAttribs elem - isFooterAttr (Xml.Attr { .. }) = and - [ Xml.qName attrKey == "id" - , attrVal == "footer" - ] - - -data Flag - = FlagHaddockPath FilePath - | FlagGhcPath FilePath - | FlagHaddockOptions String - | FlagHaddockStdOut FilePath - | FlagDiffTool FilePath - | FlagNoDiff - | FlagHelp - deriving Eq - - -options :: [OptDescr Flag] -options = - [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE") - "path to Haddock executable to exectue tests with" - , Option [] ["ghc-path"] (ReqArg FlagGhcPath "FILE") - "path to GHC executable" - , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS") - "additional options to run Haddock with" - , Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE") - "where to redirect Haddock output" - , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH") - "diff tool to use when printing failed cases" - , Option [] ["no-diff"] (NoArg FlagNoDiff) - "do not print diff for failed cases" - , Option ['h'] ["help"] (NoArg FlagHelp) - "display this help end exit" - ] - - -flagsHaddockPath :: [Flag] -> Maybe FilePath -flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ] - - -flagsGhcPath :: [Flag] -> Maybe FilePath -flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ] - - -flagsHaddockOptions :: [Flag] -> [String] -flagsHaddockOptions flags = concat - [ words opts | FlagHaddockOptions opts <- flags ] - - -flagsHaddockStdOut :: [Flag] -> Maybe FilePath -flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ] - - -flagsDiffTool :: [Flag] -> Maybe FilePath -flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ] - - -type Environment = [(String, String)] - -data ProcessConfig = ProcessConfig - { pcArgs :: [String] - , pcWorkDir :: Maybe FilePath - , pcEnv :: Maybe Environment - , pcStdIn :: Maybe Handle - , pcStdOut :: Maybe Handle - , pcStdErr :: Maybe Handle - } - - -processConfig :: ProcessConfig -processConfig = ProcessConfig - { pcArgs = [] - , pcWorkDir = Nothing - , pcEnv = Nothing - , pcStdIn = Nothing - , pcStdOut = Nothing - , pcStdErr = Nothing - } - - -runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle -runProcess' path (ProcessConfig { .. }) = runProcess - path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr - - -waitForSuccess :: String -> ProcessHandle -> IO () -waitForSuccess msg handle = do - result <- waitForProcess handle - unless (result == ExitSuccess) $ do - hPutStrLn stderr $ msg - exitFailure - - -mlast :: [a] -> Maybe a -mlast = listToMaybe . reverse - - -- *** OLD TEST RUNNER UTILITY FUNCTIONS *** -- These are considered bad and should be replaced as soon as possible. -- cgit v1.2.3