diff options
Diffstat (limited to 'html-test')
| -rwxr-xr-x | html-test/run.hs | 145 |
1 files changed, 4 insertions, 141 deletions
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. |