From 4a4d9ecf66bcb6561f7b10c07742c4b6688332b8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 12:21:45 +0200
Subject: Refactor HTML test suite boilerplate to external package.
---
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 ++++++++++++++++++++++
4 files changed, 176 insertions(+)
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
(limited to 'haddock-test/src')
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"
+ ]
--
cgit v1.2.3
From 1102352d9e830fdf6ecd8abfba50c405114d5ae2 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 13:51:23 +0200
Subject: Create utilities for storing directory configuration.
---
haddock-test/src/Test/Haddock/Config.hs | 22 ++++++++++++++++++++++
1 file changed, 22 insertions(+)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index bb226fdb..af2a460b 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -8,6 +8,21 @@ import Test.Haddock.Process
import Test.Haddock.Utils
+data DirConfig = DirConfig
+ { dcfgSrcDir :: FilePath
+ , dcfgRefDir :: FilePath
+ , dcfgOutDir :: FilePath
+ }
+
+
+defaultDirConfig :: FilePath -> DirConfig
+defaultDirConfig baseDir = DirConfig
+ { dcfgSrcDir = baseDir </> "src"
+ , dcfgRefDir = baseDir </> "ref"
+ , dcfgOutDir = baseDir </> "out"
+ }
+
+
data Config = Config
{ cfgHaddockPath :: FilePath
, cfgGhcPath :: FilePath
@@ -16,9 +31,16 @@ data Config = Config
, cfgHaddockStdOut :: FilePath
, cfgDiffTool :: Maybe FilePath
, cfgEnv :: Environment
+ , cfgDirConfig :: DirConfig
}
+cfgSrcDir, cfgRefDir, cfgOutDir :: Config -> FilePath
+cfgSrcDir = dcfgSrcDir . cfgDirConfig
+cfgRefDir = dcfgRefDir . cfgDirConfig
+cfgOutDir = dcfgOutDir . cfgDirConfig
+
+
data Flag
= FlagHaddockPath FilePath
| FlagGhcPath FilePath
--
cgit v1.2.3
From 6a2c16a0b0790ca0f3a30be8a6e96c7818514ff6 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 14:33:29 +0200
Subject: Move IO-dependent config of HTML test suite to test package.
---
haddock-test/src/Test/Haddock/Config.hs | 145 +++++++++++++++++++++++++++++++-
html-test/run.hs | 121 +-------------------------
2 files changed, 145 insertions(+), 121 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index af2a460b..b9444c3e 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -1,8 +1,30 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
module Test.Haddock.Config where
+import Control.Applicative
+import Control.Monad
+
+import qualified Data.List as List
+import Data.Maybe
+
+import Distribution.InstalledPackageInfo
+import Distribution.Package
+import Distribution.Simple.Compiler hiding (Flag)
+import Distribution.Simple.GHC
+import Distribution.Simple.PackageIndex
+import Distribution.Simple.Program
+import Distribution.Simple.Utils
+import Distribution.Verbosity
+
import System.Console.GetOpt
+import System.Directory
+import System.Exit
+import System.Environment
import System.FilePath
+import System.IO
import Test.Haddock.Process
import Test.Haddock.Utils
@@ -12,6 +34,7 @@ data DirConfig = DirConfig
{ dcfgSrcDir :: FilePath
, dcfgRefDir :: FilePath
, dcfgOutDir :: FilePath
+ , dcfgResDir :: FilePath
}
@@ -20,12 +43,14 @@ defaultDirConfig baseDir = DirConfig
{ dcfgSrcDir = baseDir </> "src"
, dcfgRefDir = baseDir </> "ref"
, dcfgOutDir = baseDir </> "out"
+ , dcfgResDir = rootDir </> "resources"
}
+ where
+ rootDir = baseDir </> ".."
data Config = Config
{ cfgHaddockPath :: FilePath
- , cfgGhcPath :: FilePath
, cfgFiles :: [FilePath]
, cfgHaddockArgs :: [String]
, cfgHaddockStdOut :: FilePath
@@ -35,10 +60,11 @@ data Config = Config
}
-cfgSrcDir, cfgRefDir, cfgOutDir :: Config -> FilePath
+cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config -> FilePath
cfgSrcDir = dcfgSrcDir . cfgDirConfig
cfgRefDir = dcfgRefDir . cfgDirConfig
cfgOutDir = dcfgOutDir . cfgDirConfig
+cfgResDir = dcfgResDir . cfgDirConfig
data Flag
@@ -90,3 +116,118 @@ options =
, Option ['h'] ["help"] (NoArg FlagHelp)
"display this help end exit"
]
+
+
+checkOpt :: [String] -> IO ([Flag], [String])
+checkOpt args = do
+ let (flags, files, errors) = getOpt Permute options args
+
+ unless (null errors) $ do
+ hPutStr stderr $ concat errors
+ exitFailure
+
+ when (FlagHelp `elem` flags) $ do
+ hPutStrLn stderr $ usageInfo "" options
+ exitSuccess
+
+ return (flags, files)
+
+
+loadConfig :: DirConfig -> [Flag] -> [String] -> IO Config
+loadConfig cfgDirConfig@(DirConfig { .. }) flags files = do
+ cfgEnv <- (:) ("haddock_datadir", dcfgResDir) <$> getEnvironment
+
+ systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment
+ cfgHaddockPath <- case flagsHaddockPath flags <|> systemHaddockPath of
+ Just path -> pure path
+ Nothing -> do
+ hPutStrLn stderr $ "Haddock executable not specified"
+ exitFailure
+
+ ghcPath <- init <$> rawSystemStdout normal cfgHaddockPath
+ ["--print-ghc-path"]
+
+ printVersions cfgEnv cfgHaddockPath
+
+ cfgFiles <- processFileArgs cfgDirConfig files
+
+ cfgHaddockArgs <- liftM concat . sequence $
+ [ pure ["--no-warnings"]
+ , pure ["--odir=" ++ dcfgOutDir]
+ , pure ["--pretty-html"]
+ , pure ["--html"]
+ , pure ["--optghc=-w"]
+ , pure $ flagsHaddockOptions flags
+ , baseDependencies ghcPath
+ ]
+
+ let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags)
+
+ cfgDiffTool <- if FlagNoDiff `elem` flags
+ then pure Nothing
+ else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
+
+ return $ Config { .. }
+
+
+printVersions :: Environment -> FilePath -> IO ()
+printVersions env haddockPath = do
+ handleHaddock <- runProcess' haddockPath $ processConfig
+ { pcEnv = Just env
+ , pcArgs = ["--version"]
+ }
+ waitForSuccess "Failed to run `haddock --version`" handleHaddock
+
+ handleGhc <- runProcess' haddockPath $ processConfig
+ { pcEnv = Just env
+ , pcArgs = ["--ghc-version"]
+ }
+ waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc
+
+
+baseDependencies :: FilePath -> IO [String]
+baseDependencies ghcPath = do
+ (_, _, cfg) <- configure normal (Just ghcPath) Nothing
+ defaultProgramConfiguration
+ pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg
+ mapM (getDependency pkgIndex) ["base", "process", "ghc-prim"]
+ where
+ getDependency pkgIndex name = case ifaces pkgIndex name of
+ [] -> do
+ hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name
+ exitFailure
+ (ifArg:_) -> pure ifArg
+ ifaces pkgIndex name = do
+ pkg <- join $ snd <$> lookupPackageName pkgIndex (PackageName name)
+ iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg
+ iface file html = "--read-interface=" ++ html ++ "," ++ file
+
+
+defaultDiffTool :: IO (Maybe FilePath)
+defaultDiffTool =
+ liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"]
+ where
+ isAvailable = liftM isJust . findProgramLocation silent
+
+
+processFileArgs :: DirConfig -> [String] -> IO [FilePath]
+processFileArgs dcfg [] =
+ map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir
+ where
+ srcDir = dcfgSrcDir dcfg
+ toModulePath = modulePath dcfg . takeBaseName
+processFileArgs dcfg args = pure $ map (processFileArg dcfg) args
+
+
+processFileArg :: DirConfig -> String -> FilePath
+processFileArg dcfg arg
+ | isSourceFile arg = arg
+ | otherwise = modulePath dcfg arg
+
+
+isSourceFile :: FilePath -> Bool
+isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
+
+
+modulePath :: DirConfig -> String -> FilePath
+modulePath dcfg mdl = dcfgSrcDir dcfg </> mdl <.> "hs"
diff --git a/html-test/run.hs b/html-test/run.hs
index e96943a0..5a2944f9 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -9,15 +9,6 @@ import Control.Monad
import Data.Maybe
import Data.List
-import Distribution.InstalledPackageInfo
-import Distribution.Package
-import Distribution.Simple.Compiler hiding (Flag)
-import Distribution.Simple.GHC
-import Distribution.Simple.PackageIndex
-import Distribution.Simple.Program
-import Distribution.Simple.Utils
-import Distribution.Verbosity
-
import System.Console.GetOpt
import System.Directory
import System.Environment
@@ -54,7 +45,8 @@ data CheckResult
main :: IO ()
main = do
- cfg <- uncurry loadConfig =<< checkOpt =<< getArgs
+ let dcfg = defaultDirConfig baseDir
+ cfg <- uncurry (loadConfig dcfg) =<< checkOpt =<< getArgs
runHaddock cfg
checkFiles cfg
@@ -101,54 +93,6 @@ runHaddock (Config { .. }) = do
waitForSuccess "Failed to run Haddock on specified test files" handle
-checkOpt :: [String] -> IO ([Flag], [String])
-checkOpt args = do
- let (flags, files, errors) = getOpt Permute options args
-
- unless (null errors) $ do
- hPutStr stderr $ concat errors
- exitFailure
-
- when (FlagHelp `elem` flags) $ do
- hPutStrLn stderr $ usageInfo "" options
- exitSuccess
-
- return (flags, files)
-
-
-loadConfig :: [Flag] -> [String] -> IO Config
-loadConfig flags files = do
- cfgEnv <- (:) ("haddock_datadir", resDir) <$> getEnvironment
-
- cfgHaddockPath <- pure $ flip fromMaybe (flagsHaddockPath flags) $
- rootDir </> "dist" </> "build" </> "haddock" </> "haddock"
-
- printVersions cfgEnv cfgHaddockPath
-
- cfgGhcPath <- flip fromMaybe (flagsGhcPath flags) <$>
- init <$> rawSystemStdout normal cfgHaddockPath ["--print-ghc-path"]
-
- cfgFiles <- processFileArgs files
-
- cfgHaddockArgs <- liftM concat . sequence $
- [ pure ["--no-warnings"]
- , pure ["--odir=" ++ outDir]
- , pure ["--pretty-html"]
- , pure ["--html"]
- , pure ["--optghc=-w"]
- , pure $ flagsHaddockOptions flags
- , baseDependencies cfgGhcPath
- ]
-
- let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags)
-
- cfgDiffTool <- if FlagNoDiff `elem` flags
- then pure Nothing
- else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
-
- return $ Config { .. }
-
-
checkModule :: String -> IO CheckResult
checkModule mdl = do
hasRef <- doesFileExist $ refFile mdl
@@ -191,67 +135,6 @@ refFile :: String -> FilePath
refFile mdl = refDir </> mdl <.> "html"
-printVersions :: Environment -> FilePath -> IO ()
-printVersions env haddockPath = do
- handle <- runProcess' haddockPath $ processConfig
- { pcEnv = Just env
- , pcArgs = ["--version"]
- }
- waitForSuccess "Failed to run `haddock --version`" handle
-
- handle <- runProcess' haddockPath $ processConfig
- { pcEnv = Just env
- , pcArgs = ["--ghc-version"]
- }
- waitForSuccess "Failed to run `haddock --ghc-version`" handle
-
-
-baseDependencies :: FilePath -> IO [String]
-baseDependencies ghcPath = do
- (_, _, cfg) <- configure normal (Just ghcPath) Nothing
- defaultProgramConfiguration
- pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg
- mapM (getDependency pkgIndex) ["base", "process", "ghc-prim"]
- where
- getDependency pkgIndex name = case ifaces pkgIndex name of
- [] -> do
- hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name
- exitFailure
- (ifArg:_) -> pure ifArg
- ifaces pkgIndex name = do
- pkg <- join $ snd <$> lookupPackageName pkgIndex (PackageName name)
- iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg
- iface file html = "--read-interface=" ++ html ++ "," ++ file
-
-
-defaultDiffTool :: IO (Maybe FilePath)
-defaultDiffTool =
- liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"]
- where
- isAvailable = liftM isJust . findProgramLocation silent
-
-
-processFileArgs :: [String] -> IO [FilePath]
-processFileArgs [] =
- map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir
- where
- toModulePath = modulePath . takeBaseName
-processFileArgs args = pure $ map processFileArg args
-
-
-processFileArg :: String -> FilePath
-processFileArg arg
- | isSourceFile arg = arg
- | otherwise = modulePath arg
-
-
-isSourceFile :: FilePath -> Bool
-isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
-
-modulePath :: String -> FilePath
-modulePath mdl = srcDir </> mdl <.> "hs"
-
-
-- *** OLD TEST RUNNER UTILITY FUNCTIONS ***
-- These are considered bad and should be replaced as soon as possible.
--
cgit v1.2.3
From 54fb845b2b322d823fb44f905bd4c4d40225259c Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
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/src')
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 66d7114dc8d310e1dc1105a0805c1c491312b43c Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 17:28:24 +0200
Subject: Make Haddock test package more generic.
---
haddock-test/src/Test/Haddock.hs | 39 +++++++++++++++++----------------
haddock-test/src/Test/Haddock/Config.hs | 26 ++++++++++++++++------
html-test/run.hs | 18 +++++++++++----
3 files changed, 53 insertions(+), 30 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 6ca57d7b..3c0c8d5f 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -19,18 +19,16 @@ 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
+ | Error String
-checkFiles :: Config -> IO ()
+checkFiles :: Config c -> IO ()
checkFiles cfg@(Config { .. }) = do
putStrLn "Testing output files..."
failed <- liftM catMaybes . forM cfgFiles $ \file -> do
@@ -42,6 +40,7 @@ checkFiles cfg@(Config { .. }) = do
Fail -> putStrLn "FAIL" >> (return $ Just mdl)
Pass -> putStrLn "PASS" >> (return Nothing)
NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing)
+ Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing
if null failed
then do
@@ -52,14 +51,14 @@ checkFiles cfg@(Config { .. }) = do
exitFailure
-maybeDiff :: Config -> [String] -> IO ()
+maybeDiff :: Config c -> [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 c -> IO ()
runHaddock (Config { .. }) = do
putStrLn "Running Haddock process..."
@@ -72,29 +71,30 @@ runHaddock (Config { .. }) = do
waitForSuccess "Failed to run Haddock on specified test files" handle
-checkModule :: Config -> String -> IO CheckResult
+checkModule :: Config c -> 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
+ mout <- ccfgRead ccfg mdl <$> readFile (outFile dcfg mdl)
+ mref <- ccfgRead ccfg mdl <$> readFile (refFile dcfg mdl)
+ return $ case (mout, mref) of
+ (Just out, Just ref)
+ | ccfgEqual ccfg out ref -> Pass
+ | otherwise -> Fail
+ _ -> Error "Failed to parse input files"
else return NoRef
where
+ ccfg = cfgCheckConfig cfg
dcfg = cfgDirConfig cfg
-diffModule :: Config -> FilePath -> String -> IO ()
+diffModule :: Config c -> 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'
+ Just out <- ccfgRead ccfg mdl <$> readFile (outFile dcfg mdl)
+ Just ref <- ccfgRead ccfg mdl <$> readFile (refFile dcfg mdl)
+ writeFile outFile' $ ccfgDump ccfg out
+ writeFile refFile' $ ccfgDump ccfg ref
putStrLn $ "Diff for module " ++ show mdl ++ ":"
hFlush stdout
@@ -105,6 +105,7 @@ diffModule cfg diff mdl = do
waitForProcess handle >> return ()
where
dcfg = cfgDirConfig cfg
+ ccfg = cfgCheckConfig cfg
outFile' = outFile dcfg mdl <.> "nolinks"
refFile' = outFile dcfg mdl <.> "ref" <.> "nolinks"
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index b9444c3e..3b6dfdeb 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -30,6 +30,13 @@ import Test.Haddock.Process
import Test.Haddock.Utils
+data CheckConfig c = CheckConfig
+ { ccfgRead :: String -> String -> Maybe c
+ , ccfgDump :: c -> String
+ , ccfgEqual :: c -> c -> Bool
+ }
+
+
data DirConfig = DirConfig
{ dcfgSrcDir :: FilePath
, dcfgRefDir :: FilePath
@@ -49,24 +56,26 @@ defaultDirConfig baseDir = DirConfig
rootDir = baseDir </> ".."
-data Config = Config
+data Config c = Config
{ cfgHaddockPath :: FilePath
, cfgFiles :: [FilePath]
, cfgHaddockArgs :: [String]
, cfgHaddockStdOut :: FilePath
, cfgDiffTool :: Maybe FilePath
, cfgEnv :: Environment
+ , cfgCheckConfig :: CheckConfig c
, cfgDirConfig :: DirConfig
}
-cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config -> FilePath
+cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config c -> FilePath
cfgSrcDir = dcfgSrcDir . cfgDirConfig
cfgRefDir = dcfgRefDir . cfgDirConfig
cfgOutDir = dcfgOutDir . cfgDirConfig
cfgResDir = dcfgResDir . cfgDirConfig
+
data Flag
= FlagHaddockPath FilePath
| FlagGhcPath FilePath
@@ -133,9 +142,9 @@ checkOpt args = do
return (flags, files)
-loadConfig :: DirConfig -> [Flag] -> [String] -> IO Config
-loadConfig cfgDirConfig@(DirConfig { .. }) flags files = do
- cfgEnv <- (:) ("haddock_datadir", dcfgResDir) <$> getEnvironment
+loadConfig :: CheckConfig c -> DirConfig -> [Flag] -> [String] -> IO (Config c)
+loadConfig ccfg dcfg flags files = do
+ cfgEnv <- (:) ("haddock_datadir", dcfgResDir dcfg) <$> getEnvironment
systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment
cfgHaddockPath <- case flagsHaddockPath flags <|> systemHaddockPath of
@@ -149,11 +158,11 @@ loadConfig cfgDirConfig@(DirConfig { .. }) flags files = do
printVersions cfgEnv cfgHaddockPath
- cfgFiles <- processFileArgs cfgDirConfig files
+ cfgFiles <- processFileArgs dcfg files
cfgHaddockArgs <- liftM concat . sequence $
[ pure ["--no-warnings"]
- , pure ["--odir=" ++ dcfgOutDir]
+ , pure ["--odir=" ++ dcfgOutDir dcfg]
, pure ["--pretty-html"]
, pure ["--html"]
, pure ["--optghc=-w"]
@@ -167,6 +176,9 @@ loadConfig cfgDirConfig@(DirConfig { .. }) flags files = do
then pure Nothing
else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
+ let cfgCheckConfig = ccfg
+ let cfgDirConfig = dcfg
+
return $ Config { .. }
diff --git a/html-test/run.hs b/html-test/run.hs
index 48c733d0..22a06ba3 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -5,16 +5,26 @@ import System.Environment
import System.FilePath
import Test.Haddock
+import Test.Haddock.Xhtml
+import qualified Text.XML.Light as Xml
-baseDir :: FilePath
-baseDir = takeDirectory __FILE__
+
+checkConfig :: CheckConfig Xml.Element
+checkConfig = CheckConfig
+ { ccfgRead = \_ input -> strip <$> Xml.parseXMLDoc input
+ , ccfgDump = Xml.ppElement
+ , ccfgEqual = (==)
+ }
+
+
+dirConfig :: DirConfig
+dirConfig = defaultDirConfig $ takeDirectory __FILE__
main :: IO ()
main = do
- let dcfg = defaultDirConfig baseDir
- cfg <- uncurry (loadConfig dcfg) =<< checkOpt =<< getArgs
+ cfg <- uncurry (loadConfig checkConfig dirConfig) =<< checkOpt =<< getArgs
runHaddock cfg
checkFiles cfg
--
cgit v1.2.3
From ad82e40c858e313f8ff06eed058618fa1eaa8c19 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 20:27:59 +0200
Subject: Create convenience wrappers to simplify in test entry points.
---
haddock-test/src/Test/Haddock.hs | 4 ++++
haddock-test/src/Test/Haddock/Config.hs | 4 ++++
html-test/run.hs | 5 +----
3 files changed, 9 insertions(+), 4 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 3c0c8d5f..de293eab 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -28,6 +28,10 @@ data CheckResult
| Error String
+runAndCheck :: Config c -> IO ()
+runAndCheck cfg = runHaddock cfg >> checkFiles cfg
+
+
checkFiles :: Config c -> IO ()
checkFiles cfg@(Config { .. }) = do
putStrLn "Testing output files..."
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 3b6dfdeb..3068e52b 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -127,6 +127,10 @@ options =
]
+parseArgs :: CheckConfig c -> DirConfig -> [String] -> IO (Config c)
+parseArgs ccfg dcfg args = uncurry (loadConfig ccfg dcfg) =<< checkOpt args
+
+
checkOpt :: [String] -> IO ([Flag], [String])
checkOpt args = do
let (flags, files, errors) = getOpt Permute options args
diff --git a/html-test/run.hs b/html-test/run.hs
index 22a06ba3..2758bf56 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -23,10 +23,7 @@ dirConfig = defaultDirConfig $ takeDirectory __FILE__
main :: IO ()
-main = do
- cfg <- uncurry (loadConfig checkConfig dirConfig) =<< checkOpt =<< getArgs
- runHaddock cfg
- checkFiles cfg
+main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs
-- *** OLD TEST RUNNER UTILITY FUNCTIONS ***
--
cgit v1.2.3
From 188b8aae6efa5d3f41687c84399343494f6bf975 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
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/src')
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 b1c899c2ccb0b7d12aa7f4217dff516d354f2055 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 21:13:35 +0200
Subject: Remove no longer useful test option.
---
haddock-test/src/Test/Haddock/Config.hs | 7 -------
1 file changed, 7 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 0c9bdb19..4f6bb818 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -83,7 +83,6 @@ cfgResDir = dcfgResDir . cfgDirConfig
data Flag
= FlagHaddockPath FilePath
- | FlagGhcPath FilePath
| FlagHaddockOptions String
| FlagHaddockStdOut FilePath
| FlagDiffTool FilePath
@@ -96,10 +95,6 @@ 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 ]
@@ -117,8 +112,6 @@ 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")
--
cgit v1.2.3
From 869ee23cc7ec1bd2fa9299323b74d71fe6023ef2 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 21:21:02 +0200
Subject: Change extension of test files used for diffing.
---
haddock-test/src/Test/Haddock.hs | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index a6b9ea8a..78204840 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -110,8 +110,8 @@ diffModule cfg diff mdl = do
where
dcfg = cfgDirConfig cfg
ccfg = cfgCheckConfig cfg
- outFile' = outFile dcfg mdl <.> "nolinks"
- refFile' = outFile dcfg mdl <.> "ref" <.> "nolinks"
+ outFile' = outFile dcfg mdl <.> "dump"
+ refFile' = outFile dcfg mdl <.> "ref" <.> "dump"
outFile :: DirConfig -> String -> FilePath
--
cgit v1.2.3
From 5934c411a8ebe0ba1a317f7c95babfbd63106254 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 14 Aug 2015 00:34:10 +0200
Subject: Refactor and simplify XHTML helper module of test package.
---
haddock-test/src/Test/Haddock/Xhtml.hs | 40 ++++++++++++++++++++--------------
html-test/run.hs | 17 +++++++++------
2 files changed, 34 insertions(+), 23 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
index 35f5910a..b6941496 100644
--- a/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -2,47 +2,55 @@
{-# LANGUAGE StandaloneDeriving #-}
-module Test.Haddock.Xhtml where
+module Test.Haddock.Xhtml
+ ( Xhtml(..)
+ , parseXhtml, dumpXhtml
+ , stripLinks, stripFooter
+ ) where
-import Control.Monad
-
import Data.Generics.Aliases
import Data.Generics.Schemes
import Text.XML.Light
-deriving instance Eq Content
+newtype Xhtml = Xhtml
+ { xhtmlElement :: Element
+ } deriving Eq
+
+
+-- TODO: Find a way to avoid warning about orphan instances.
deriving instance Eq Element
+deriving instance Eq Content
deriving instance Eq CData
-readXml :: FilePath -> IO (Maybe Element)
-readXml = liftM parseXMLDoc . readFile
+parseXhtml :: String -> Maybe Xhtml
+parseXhtml = fmap Xhtml . parseXMLDoc
-strip :: Element -> Element
-strip = stripFooter . stripLinks
+dumpXhtml :: Xhtml -> String
+dumpXhtml = ppElement . xhtmlElement
-stripLinks :: Element -> Element
+stripLinks :: Xhtml -> Xhtml
stripLinks =
- everywhere (mkT unlink)
+ Xhtml . everywhere (mkT unlink) . xhtmlElement
where
unlink attr@(Attr { attrKey = key })
| qName key == "href" = attr { attrVal = "#" }
| otherwise = attr
-stripFooter :: Element -> Element
+stripFooter :: Xhtml -> Xhtml
stripFooter =
- everywhere (mkT defoot)
+ Xhtml . everywhere (mkT defoot) . xhtmlElement
where
- defoot elem
- | isFooter elem = elem { elContent = [] }
- | otherwise = elem
- isFooter elem = any isFooterAttr $ elAttribs elem
+ defoot el
+ | isFooter el = el { elContent = [] }
+ | otherwise = el
+ isFooter el = any isFooterAttr $ elAttribs el
isFooterAttr (Attr { .. }) = and
[ qName attrKey == "id"
, attrVal == "footer"
diff --git a/html-test/run.hs b/html-test/run.hs
index 2758bf56..ab007f57 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -7,13 +7,11 @@ import System.FilePath
import Test.Haddock
import Test.Haddock.Xhtml
-import qualified Text.XML.Light as Xml
-
-checkConfig :: CheckConfig Xml.Element
+checkConfig :: CheckConfig Xhtml
checkConfig = CheckConfig
- { ccfgRead = \_ input -> strip <$> Xml.parseXMLDoc input
- , ccfgDump = Xml.ppElement
+ { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXhtml input
+ , ccfgDump = dumpXhtml
, ccfgEqual = (==)
}
@@ -26,8 +24,13 @@ main :: IO ()
main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs
--- *** OLD TEST RUNNER UTILITY FUNCTIONS ***
--- These are considered bad and should be replaced as soon as possible.
+stripIfRequired :: String -> Xhtml -> Xhtml
+stripIfRequired mdl =
+ stripLinks' . stripFooter
+ where
+ stripLinks'
+ | mdl `elem` preserveLinksModules = id
+ | otherwise = stripFooter
-- | List of modules in which we don't 'stripLinks'
--
cgit v1.2.3
From 1cb714e35337a6b17d7fc37f086914f43f7f2da3 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 14 Aug 2015 20:41:41 +0200
Subject: Implement utility functions for conditional link stripping.
---
haddock-test/src/Test/Haddock/Xhtml.hs | 27 ++++++++++++++++++++++-----
1 file changed, 22 insertions(+), 5 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
index b6941496..d8c26249 100644
--- a/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -5,7 +5,7 @@
module Test.Haddock.Xhtml
( Xhtml(..)
, parseXhtml, dumpXhtml
- , stripLinks, stripFooter
+ , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter
) where
@@ -35,14 +35,31 @@ dumpXhtml = ppElement . xhtmlElement
stripLinks :: Xhtml -> Xhtml
-stripLinks =
- Xhtml . everywhere (mkT unlink) . xhtmlElement
+stripLinks = stripLinksWhen (const True)
+
+
+stripLinksWhen :: (String -> Bool) -> Xhtml -> Xhtml
+stripLinksWhen p =
+ processAnchors unlink
+ where
+ unlink attr@(Attr { attrKey = key, attrVal = val })
+ | qName key == "href" && p val = attr { attrVal = "#" }
+ | otherwise = attr
+
+
+stripAnchorsWhen :: (String -> Bool) -> Xhtml -> Xhtml
+stripAnchorsWhen p =
+ processAnchors unname
where
- unlink attr@(Attr { attrKey = key })
- | qName key == "href" = attr { attrVal = "#" }
+ unname attr@(Attr { attrKey = key, attrVal = val })
+ | qName key == "name" && p val = attr { attrVal = "" }
| otherwise = attr
+processAnchors :: (Attr -> Attr) -> Xhtml -> Xhtml
+processAnchors f = Xhtml . everywhere (mkT f) . xhtmlElement
+
+
stripFooter :: Xhtml -> Xhtml
stripFooter =
Xhtml . everywhere (mkT defoot) . xhtmlElement
--
cgit v1.2.3
From 5568091a53ee53f742b6fe9f11b3edd1664228b9 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 17 Aug 2015 12:54:48 +0200
Subject: Implement output accepting mechanism in test package.
---
haddock-test/src/Test/Haddock.hs | 16 +++++++++++++++-
haddock-test/src/Test/Haddock/Config.hs | 6 ++++++
2 files changed, 21 insertions(+), 1 deletion(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 78204840..a2c6609a 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -29,7 +29,11 @@ data CheckResult
runAndCheck :: Config c -> IO ()
-runAndCheck cfg = runHaddock cfg >> checkFiles cfg
+runAndCheck cfg = do
+ runHaddock cfg
+ if cfgAccept cfg
+ then acceptFiles cfg
+ else checkFiles cfg
checkFiles :: Config c -> IO ()
@@ -55,6 +59,16 @@ checkFiles cfg@(Config { .. }) = do
exitFailure
+acceptFiles :: Config c -> IO ()
+acceptFiles (Config { cfgFiles = files, cfgDirConfig = dcfg }) = do
+
+ forM_ files $ \file -> do
+ let mdl = takeBaseName file
+ putStr $ "Accepting " ++ mdl ++ "... "
+ copyFile (outFile dcfg mdl) (refFile dcfg mdl)
+ putStrLn "DONE"
+
+
maybeDiff :: Config c -> [String] -> IO ()
maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure ()
maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) mdls = do
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 4f6bb818..451cd809 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -68,6 +68,7 @@ data Config c = Config
, cfgHaddockStdOut :: FilePath
, cfgDiffTool :: Maybe FilePath
, cfgEnv :: Environment
+ , cfgAccept :: Bool
, cfgCheckConfig :: CheckConfig c
, cfgDirConfig :: DirConfig
}
@@ -87,6 +88,7 @@ data Flag
| FlagHaddockStdOut FilePath
| FlagDiffTool FilePath
| FlagNoDiff
+ | FlagAccept
| FlagHelp
deriving Eq
@@ -118,6 +120,8 @@ options =
"where to redirect Haddock output"
, Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH")
"diff tool to use when printing failed cases"
+ , Option ['a'] ["accept"] (NoArg FlagAccept)
+ "accept generated output"
, Option [] ["no-diff"] (NoArg FlagNoDiff)
"do not print diff for failed cases"
, Option ['h'] ["help"] (NoArg FlagHelp)
@@ -178,6 +182,8 @@ loadConfig ccfg dcfg flags files = do
then pure Nothing
else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
+ let cfgAccept = FlagAccept `elem` flags
+
let cfgCheckConfig = ccfg
let cfgDirConfig = dcfg
--
cgit v1.2.3
From 163da5a4b6268de54594e18f69f06799df637305 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 18:06:59 +0200
Subject: Create utility function for recursive obtaining directory contents.
---
haddock-test/src/Test/Haddock/Utils.hs | 25 +++++++++++++++++++++++++
1 file changed, 25 insertions(+)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs
index 1d57107f..4640fe97 100644
--- a/haddock-test/src/Test/Haddock/Utils.hs
+++ b/haddock-test/src/Test/Haddock/Utils.hs
@@ -1,8 +1,33 @@
module Test.Haddock.Utils where
+import Control.Monad
+
import Data.Maybe
+import System.Directory
+import System.FilePath
+
mlast :: [a] -> Maybe a
mlast = listToMaybe . reverse
+
+
+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
+partitionM _ [] = pure ([], [])
+partitionM p (x:xs) = do
+ (ss, fs) <- partitionM p xs
+ b <- p x
+ pure $ if b then (x:ss, fs) else (ss, x:fs)
+
+
+getDirectoryTree :: FilePath -> IO [FilePath]
+getDirectoryTree path = do
+ (dirs, files) <- partitionM isDirectory =<< contents
+ subfiles <- fmap concat . forM dirs $ \dir ->
+ map (dir </>) <$> getDirectoryTree (path </> dir)
+ pure $ files ++ subfiles
+ where
+ contents = filter realEntry <$> getDirectoryContents path
+ isDirectory entry = doesDirectoryExist $ path </> entry
+ realEntry entry = not $ entry == "." || entry == ".."
--
cgit v1.2.3
From e614916d940943a1f4f7cd77d9957246d164ab1d Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 18:47:11 +0200
Subject: Make Haddock test package more generic.
---
haddock-test/src/Test/Haddock.hs | 90 ++++++++++++++++-----------------
haddock-test/src/Test/Haddock/Config.hs | 50 ++++++++++++------
2 files changed, 78 insertions(+), 62 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index a2c6609a..f31ec53f 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -31,21 +31,20 @@ data CheckResult
runAndCheck :: Config c -> IO ()
runAndCheck cfg = do
runHaddock cfg
- if cfgAccept cfg
- then acceptFiles cfg
- else checkFiles cfg
+ checkFiles cfg
checkFiles :: Config c -> 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
+ files <- getDirectoryContents (cfgOutDir cfg)
+ failed <- liftM catMaybes . forM files $ \file -> do
+ putStr $ "Checking \"" ++ file ++ "\"... "
+
+ status <- checkFile cfg file
case status of
- Fail -> putStrLn "FAIL" >> (return $ Just mdl)
+ Fail -> putStrLn "FAIL" >> (return $ Just file)
Pass -> putStrLn "PASS" >> (return Nothing)
NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing)
Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing
@@ -59,43 +58,38 @@ checkFiles cfg@(Config { .. }) = do
exitFailure
-acceptFiles :: Config c -> IO ()
-acceptFiles (Config { cfgFiles = files, cfgDirConfig = dcfg }) = do
-
- forM_ files $ \file -> do
- let mdl = takeBaseName file
- putStr $ "Accepting " ++ mdl ++ "... "
- copyFile (outFile dcfg mdl) (refFile dcfg mdl)
- putStrLn "DONE"
-
-
-maybeDiff :: Config c -> [String] -> IO ()
+maybeDiff :: Config c -> [FilePath] -> IO ()
maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure ()
-maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) mdls = do
+maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
putStrLn "Diffing failed cases..."
- forM_ mdls $ diffModule cfg diff
+ forM_ files $ diffFile cfg diff
runHaddock :: Config c -> 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 c -> String -> IO CheckResult
-checkModule cfg mdl = do
- hasRef <- doesFileExist $ refFile dcfg mdl
+ putStrLn "Generating documentation..."
+ forM_ cfgPackages $ \tpkg -> do
+ handle <- runProcess' cfgHaddockPath $ processConfig
+ { pcArgs = concat
+ [ cfgHaddockArgs
+ , pure $ "--odir=" ++ outDir cfgDirConfig tpkg
+ , tpkgFiles tpkg
+ ]
+ , pcEnv = Just $ cfgEnv
+ , pcStdOut = Just $ haddockStdOut
+ }
+ waitForSuccess "Failed to run Haddock on specified test files" handle
+
+
+checkFile :: Config c -> FilePath -> IO CheckResult
+checkFile cfg file = do
+ hasRef <- doesFileExist $ refFile dcfg file
if hasRef
then do
- mout <- ccfgRead ccfg mdl <$> readFile (outFile dcfg mdl)
- mref <- ccfgRead ccfg mdl <$> readFile (refFile dcfg mdl)
+ mout <- ccfgRead ccfg file <$> readFile (outFile dcfg file)
+ mref <- ccfgRead ccfg file <$> readFile (refFile dcfg file)
return $ case (mout, mref) of
(Just out, Just ref)
| ccfgEqual ccfg out ref -> Pass
@@ -107,14 +101,14 @@ checkModule cfg mdl = do
dcfg = cfgDirConfig cfg
-diffModule :: Config c -> FilePath -> String -> IO ()
-diffModule cfg diff mdl = do
- Just out <- ccfgRead ccfg mdl <$> readFile (outFile dcfg mdl)
- Just ref <- ccfgRead ccfg mdl <$> readFile (refFile dcfg mdl)
+diffFile :: Config c -> FilePath -> FilePath -> IO ()
+diffFile cfg diff file = do
+ Just out <- ccfgRead ccfg file <$> readFile (outFile dcfg file)
+ Just ref <- ccfgRead ccfg file <$> readFile (refFile dcfg file)
writeFile outFile' $ ccfgDump ccfg out
writeFile refFile' $ ccfgDump ccfg ref
- putStrLn $ "Diff for module " ++ show mdl ++ ":"
+ putStrLn $ "Diff for file \"" ++ file ++ "\":"
hFlush stdout
handle <- runProcess' diff $ processConfig
{ pcArgs = [outFile', refFile']
@@ -124,13 +118,17 @@ diffModule cfg diff mdl = do
where
dcfg = cfgDirConfig cfg
ccfg = cfgCheckConfig cfg
- outFile' = outFile dcfg mdl <.> "dump"
- refFile' = outFile dcfg mdl <.> "ref" <.> "dump"
+ outFile' = outFile dcfg file <.> "dump"
+ refFile' = outFile dcfg file <.> "ref" <.> "dump"
+
+
+outDir :: DirConfig -> TestPackage -> FilePath
+outDir dcfg tpkg = dcfgOutDir dcfg </> tpkgName tpkg
-outFile :: DirConfig -> String -> FilePath
-outFile dcfg mdl = dcfgOutDir dcfg </> mdl <.> "html"
+outFile :: DirConfig -> FilePath -> FilePath
+outFile dcfg file = dcfgOutDir dcfg </> file
-refFile :: DirConfig -> String -> FilePath
-refFile dcfg mdl = dcfgRefDir dcfg </> mdl <.> "html"
+refFile :: DirConfig -> FilePath -> FilePath
+refFile dcfg file = dcfgRefDir dcfg </> file
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 451cd809..15a53829 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -2,7 +2,7 @@
module Test.Haddock.Config
- ( CheckConfig(..), DirConfig(..), Config(..)
+ ( TestPackage(..), CheckConfig(..), DirConfig(..), Config(..)
, defaultDirConfig
, cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir
, parseArgs, checkOpt, loadConfig
@@ -35,6 +35,12 @@ import Test.Haddock.Process
import Test.Haddock.Utils
+data TestPackage = TestPackage
+ { tpkgName :: String
+ , tpkgFiles :: [FilePath]
+ }
+
+
data CheckConfig c = CheckConfig
{ ccfgRead :: String -> String -> Maybe c
, ccfgDump :: c -> String
@@ -63,7 +69,7 @@ defaultDirConfig baseDir = DirConfig
data Config c = Config
{ cfgHaddockPath :: FilePath
- , cfgFiles :: [FilePath]
+ , cfgPackages :: [TestPackage]
, cfgHaddockArgs :: [String]
, cfgHaddockStdOut :: FilePath
, cfgDiffTool :: Maybe FilePath
@@ -164,7 +170,7 @@ loadConfig ccfg dcfg flags files = do
printVersions cfgEnv cfgHaddockPath
- cfgFiles <- processFileArgs dcfg files
+ cfgPackages <- processFileArgs dcfg files
cfgHaddockArgs <- liftM concat . sequence $
[ pure ["--no-warnings"]
@@ -230,24 +236,36 @@ defaultDiffTool =
isAvailable = liftM isJust . findProgramLocation silent
-processFileArgs :: DirConfig -> [String] -> IO [FilePath]
+processFileArgs :: DirConfig -> [String] -> IO [TestPackage]
processFileArgs dcfg [] =
- map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir
+ processFileArgs dcfg . filter isValidEntry =<< getDirectoryContents srcDir
where
+ isValidEntry entry = entry /= "." && entry /= ".."
srcDir = dcfgSrcDir dcfg
- toModulePath = modulePath dcfg . takeBaseName
-processFileArgs dcfg args = pure $ map (processFileArg dcfg) args
+processFileArgs dcfg args = processFileArgs' dcfg args
+
+
+processFileArgs' :: DirConfig -> [String] -> IO [TestPackage]
+processFileArgs' dcfg args = do
+ (mdls, dirs) <- partitionM doesDirectoryExist' args
+ rootPkg <- pure $ TestPackage
+ { tpkgName = ""
+ , tpkgFiles = map (processFileArg dcfg) mdls
+ }
+ otherPkgs <- forM dirs $ \dir -> do
+ files <- getDirectoryContents dir
+ pure $ TestPackage
+ { tpkgName = dir
+ , tpkgFiles = map ((dcfgSrcDir dcfg </> dir) </>) files
+ }
+ pure $ rootPkg:otherPkgs
+ where
+ doesDirectoryExist' path = doesDirectoryExist (dcfgSrcDir dcfg </> path)
processFileArg :: DirConfig -> String -> FilePath
processFileArg dcfg arg
| isSourceFile arg = arg
- | otherwise = modulePath dcfg arg
-
-
-isSourceFile :: FilePath -> Bool
-isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
-
-
-modulePath :: DirConfig -> String -> FilePath
-modulePath dcfg mdl = dcfgSrcDir dcfg </> mdl <.> "hs"
+ | otherwise = dcfgSrcDir dcfg </> arg </> ".hs"
+ where
+ isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
--
cgit v1.2.3
From c2a4125e3a5158078d8c172a840f7292dcf3ab28 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 20:32:12 +0200
Subject: Fix path handling in test runner.
---
haddock-test/src/Test/Haddock/Config.hs | 25 ++++++++++---------------
1 file changed, 10 insertions(+), 15 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 15a53829..1b89e276 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -238,34 +238,29 @@ defaultDiffTool =
processFileArgs :: DirConfig -> [String] -> IO [TestPackage]
processFileArgs dcfg [] =
- processFileArgs dcfg . filter isValidEntry =<< getDirectoryContents srcDir
+ processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir
where
- isValidEntry entry = entry /= "." && entry /= ".."
+ isValidEntry entry
+ | hasExtension entry = takeExtension entry `elem` [".hs", ".lhs"]
+ | otherwise = entry /= "." && entry /= ".."
srcDir = dcfgSrcDir dcfg
processFileArgs dcfg args = processFileArgs' dcfg args
processFileArgs' :: DirConfig -> [String] -> IO [TestPackage]
processFileArgs' dcfg args = do
- (mdls, dirs) <- partitionM doesDirectoryExist' args
+ (dirs, mdls) <- partitionM doesDirectoryExist' . map takeBaseName $ args
rootPkg <- pure $ TestPackage
{ tpkgName = ""
- , tpkgFiles = map (processFileArg dcfg) mdls
+ , tpkgFiles = map (srcDir </>) mdls
}
otherPkgs <- forM dirs $ \dir -> do
- files <- getDirectoryContents dir
+ files <- getDirectoryContents (srcDir </> dir)
pure $ TestPackage
{ tpkgName = dir
- , tpkgFiles = map ((dcfgSrcDir dcfg </> dir) </>) files
+ , tpkgFiles = map ((srcDir </> dir) </>) files
}
pure $ rootPkg:otherPkgs
where
- doesDirectoryExist' path = doesDirectoryExist (dcfgSrcDir dcfg </> path)
-
-
-processFileArg :: DirConfig -> String -> FilePath
-processFileArg dcfg arg
- | isSourceFile arg = arg
- | otherwise = dcfgSrcDir dcfg </> arg </> ".hs"
- where
- isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
+ doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
+ srcDir = dcfgSrcDir dcfg
--
cgit v1.2.3
From bb7d45db2b79f310ab8c2601b47399d5ac69e085 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 20:43:52 +0200
Subject: Make it possible to specify ignored files for test output.
---
haddock-test/src/Test/Haddock.hs | 4 +++-
haddock-test/src/Test/Haddock/Config.hs | 2 ++
2 files changed, 5 insertions(+), 1 deletion(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index f31ec53f..581b0d10 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -38,7 +38,7 @@ checkFiles :: Config c -> IO ()
checkFiles cfg@(Config { .. }) = do
putStrLn "Testing output files..."
- files <- getDirectoryContents (cfgOutDir cfg)
+ files <- ignore <$> getDirectoryContents (cfgOutDir cfg)
failed <- liftM catMaybes . forM files $ \file -> do
putStr $ "Checking \"" ++ file ++ "\"... "
@@ -56,6 +56,8 @@ checkFiles cfg@(Config { .. }) = do
else do
maybeDiff cfg failed
exitFailure
+ where
+ ignore = filter (not . dcfgCheckIgnore cfgDirConfig)
maybeDiff :: Config c -> [FilePath] -> IO ()
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 1b89e276..256e9a93 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -53,6 +53,7 @@ data DirConfig = DirConfig
, dcfgRefDir :: FilePath
, dcfgOutDir :: FilePath
, dcfgResDir :: FilePath
+ , dcfgCheckIgnore :: FilePath -> Bool
}
@@ -62,6 +63,7 @@ defaultDirConfig baseDir = DirConfig
, dcfgRefDir = baseDir </> "ref"
, dcfgOutDir = baseDir </> "out"
, dcfgResDir = rootDir </> "resources"
+ , dcfgCheckIgnore = const False
}
where
rootDir = baseDir </> ".."
--
cgit v1.2.3
From eff66b0bbf6f7ccc8f24ab21131be59b137fea47 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 21:55:15 +0200
Subject: Fix bug with not all test output files being checked.
---
haddock-test/src/Test/Haddock.hs | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 581b0d10..ab6ce775 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -19,6 +19,7 @@ import System.Process
import Test.Haddock.Config
import Test.Haddock.Process
+import Test.Haddock.Utils
data CheckResult
@@ -38,7 +39,7 @@ checkFiles :: Config c -> IO ()
checkFiles cfg@(Config { .. }) = do
putStrLn "Testing output files..."
- files <- ignore <$> getDirectoryContents (cfgOutDir cfg)
+ files <- ignore <$> getDirectoryTree (cfgOutDir cfg)
failed <- liftM catMaybes . forM files $ \file -> do
putStr $ "Checking \"" ++ file ++ "\"... "
--
cgit v1.2.3
From ebf06f31c1eaf0e9d045f8472548196d47d53431 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 22:30:06 +0200
Subject: Fix bug with test runner invoking Haddock in incorrect mode.
---
haddock-test/src/Test/Haddock/Config.hs | 2 --
html-test/Main.hs | 6 +++++-
hypsrc-test/Main.hs | 9 ++++++++-
3 files changed, 13 insertions(+), 4 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 256e9a93..9fca3348 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -177,8 +177,6 @@ loadConfig ccfg dcfg flags files = do
cfgHaddockArgs <- liftM concat . sequence $
[ pure ["--no-warnings"]
, pure ["--odir=" ++ dcfgOutDir dcfg]
- , pure ["--pretty-html"]
- , pure ["--html"]
, pure ["--optghc=-w"]
, pure $ flagsHaddockOptions flags
, baseDependencies ghcPath
diff --git a/html-test/Main.hs b/html-test/Main.hs
index 49e769f5..724d35ec 100755
--- a/html-test/Main.hs
+++ b/html-test/Main.hs
@@ -25,7 +25,11 @@ dirConfig = (defaultDirConfig $ takeDirectory __FILE__)
main :: IO ()
-main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs
+main = do
+ cfg <- parseArgs checkConfig dirConfig =<< getArgs
+ runAndCheck $ cfg
+ { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--pretty-html", "--html"]
+ }
stripIfRequired :: String -> Xhtml -> Xhtml
diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs
index 7fa4a705..06cf8546 100644
--- a/hypsrc-test/Main.hs
+++ b/hypsrc-test/Main.hs
@@ -30,7 +30,14 @@ dirConfig = (defaultDirConfig $ takeDirectory __FILE__)
main :: IO ()
-main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs
+main = do
+ cfg <- parseArgs checkConfig dirConfig =<< getArgs
+ runAndCheck $ cfg
+ { cfgHaddockArgs = cfgHaddockArgs cfg ++
+ [ "--pretty-html"
+ , "--hyperlinked-source"
+ ]
+ }
checkIgnore :: FilePath -> Bool
--
cgit v1.2.3
From 48b5858b9b37e4190c475558a6c88dc923ec5c5a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 23:06:00 +0200
Subject: Fix path handling in test module loader.
---
haddock-test/src/Test/Haddock/Config.hs | 20 ++++++++++++++++----
1 file changed, 16 insertions(+), 4 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 9fca3348..f3056061 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -241,8 +241,8 @@ processFileArgs dcfg [] =
processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir
where
isValidEntry entry
- | hasExtension entry = takeExtension entry `elem` [".hs", ".lhs"]
- | otherwise = entry /= "." && entry /= ".."
+ | hasExtension entry = isSourceFile entry
+ | otherwise = isRealDir entry
srcDir = dcfgSrcDir dcfg
processFileArgs dcfg args = processFileArgs' dcfg args
@@ -255,12 +255,24 @@ processFileArgs' dcfg args = do
, tpkgFiles = map (srcDir </>) mdls
}
otherPkgs <- forM dirs $ \dir -> do
- files <- getDirectoryContents (srcDir </> dir)
+ let srcDir' = srcDir </> dir
+ files <- filterM (isModule dir) =<< getDirectoryContents srcDir'
pure $ TestPackage
{ tpkgName = dir
- , tpkgFiles = map ((srcDir </> dir) </>) files
+ , tpkgFiles = map (srcDir' </>) files
}
pure $ rootPkg:otherPkgs
where
doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
+ isModule dir file = (isSourceFile file &&) <$>
+ doesFileExist (srcDir </> dir </> file)
+ doesFileExist' dir path = doesFileExist (srcDir </> dir </> path)
srcDir = dcfgSrcDir dcfg
+
+
+isSourceFile :: FilePath -> Bool
+isSourceFile file = takeExtension file `elem` [".hs", ".lhs"]
+
+
+isRealDir :: FilePath -> Bool
+isRealDir dir = not $ dir `elem` [".", ".."]
--
cgit v1.2.3
From d36a1a5fb39529e396203b4da0c396ceedda133b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 23:11:59 +0200
Subject: Make test runner ignore test packages with no modules.
---
haddock-test/src/Test/Haddock/Config.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index f3056061..b1fd2098 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -261,7 +261,7 @@ processFileArgs' dcfg args = do
{ tpkgName = dir
, tpkgFiles = map (srcDir' </>) files
}
- pure $ rootPkg:otherPkgs
+ pure . filter (not . null . tpkgFiles) $ rootPkg:otherPkgs
where
doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
isModule dir file = (isSourceFile file &&) <$>
--
cgit v1.2.3
From 863d33c4d125e13f87193802f6d4faed38da24db Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 23:42:25 +0200
Subject: Fix bug with unnecessary checking old test output.
---
haddock-test/src/Test/Haddock.hs | 4 +++-
haddock-test/src/Test/Haddock/Utils.hs | 10 ++++++++++
2 files changed, 13 insertions(+), 1 deletion(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index ab6ce775..18ae38ca 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -69,9 +69,11 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
runHaddock :: Config c -> IO ()
-runHaddock (Config { .. }) = do
+runHaddock cfg@(Config { .. }) = do
haddockStdOut <- openFile cfgHaddockStdOut WriteMode
+ createEmptyDirectory $ cfgOutDir cfg
+
putStrLn "Generating documentation..."
forM_ cfgPackages $ \tpkg -> do
handle <- runProcess' cfgHaddockPath $ processConfig
diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs
index 4640fe97..4f97fa72 100644
--- a/haddock-test/src/Test/Haddock/Utils.hs
+++ b/haddock-test/src/Test/Haddock/Utils.hs
@@ -21,6 +21,10 @@ partitionM p (x:xs) = do
pure $ if b then (x:ss, fs) else (ss, x:fs)
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM mb action = mb >>= \b -> when b action
+
+
getDirectoryTree :: FilePath -> IO [FilePath]
getDirectoryTree path = do
(dirs, files) <- partitionM isDirectory =<< contents
@@ -31,3 +35,9 @@ getDirectoryTree path = do
contents = filter realEntry <$> getDirectoryContents path
isDirectory entry = doesDirectoryExist $ path </> entry
realEntry entry = not $ entry == "." || entry == ".."
+
+
+createEmptyDirectory :: FilePath -> IO ()
+createEmptyDirectory path = do
+ whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
+ createDirectory path
--
cgit v1.2.3
From cf22686d11bf9923926f3380793e64d2ff4141fc Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 19 Aug 2015 13:04:54 +0200
Subject: Re-implement test acceptance functionality.
---
haddock-test/src/Test/Haddock.hs | 13 ++++++++++++-
1 file changed, 12 insertions(+), 1 deletion(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 18ae38ca..41e15978 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -27,6 +27,8 @@ data CheckResult
| Pass
| NoRef
| Error String
+ | Accepted
+ deriving Eq
runAndCheck :: Config c -> IO ()
@@ -43,12 +45,13 @@ checkFiles cfg@(Config { .. }) = do
failed <- liftM catMaybes . forM files $ \file -> do
putStr $ "Checking \"" ++ file ++ "\"... "
- status <- checkFile cfg file
+ status <- maybeAcceptFile cfg file =<< checkFile cfg file
case status of
Fail -> putStrLn "FAIL" >> (return $ Just file)
Pass -> putStrLn "PASS" >> (return Nothing)
NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing)
Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing
+ Accepted -> putStrLn "ACCEPTED" >> return Nothing
if null failed
then do
@@ -127,6 +130,14 @@ diffFile cfg diff file = do
refFile' = outFile dcfg file <.> "ref" <.> "dump"
+maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult
+maybeAcceptFile cfg@(Config { cfgDirConfig = dcfg }) file result
+ | cfgAccept cfg && result `elem` [NoRef, Fail] = do
+ copyFile (outFile dcfg file) (refFile dcfg file)
+ pure Accepted
+maybeAcceptFile _ _ result = pure result
+
+
outDir :: DirConfig -> TestPackage -> FilePath
outDir dcfg tpkg = dcfgOutDir dcfg </> tpkgName tpkg
--
cgit v1.2.3
From 1b758285744eb1b7a34bc63a131738c28f0e089a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 19 Aug 2015 13:06:22 +0200
Subject: Fix warning about no longer needed definition.
---
haddock-test/src/Test/Haddock/Config.hs | 1 -
1 file changed, 1 deletion(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index b1fd2098..fff84921 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -266,7 +266,6 @@ processFileArgs' dcfg args = do
doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
isModule dir file = (isSourceFile file &&) <$>
doesFileExist (srcDir </> dir </> file)
- doesFileExist' dir path = doesFileExist (srcDir </> dir </> path)
srcDir = dcfgSrcDir dcfg
--
cgit v1.2.3
From 7d0317a9210ddbb4f00976318910018fa9abea99 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 19 Aug 2015 16:37:43 +0200
Subject: Fix bug with test runner failing when run on multiple test packages.
---
haddock-test/src/Test/Haddock.hs | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 41e15978..87c16739 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -73,12 +73,11 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
runHaddock :: Config c -> IO ()
runHaddock cfg@(Config { .. }) = do
- haddockStdOut <- openFile cfgHaddockStdOut WriteMode
-
createEmptyDirectory $ cfgOutDir cfg
putStrLn "Generating documentation..."
forM_ cfgPackages $ \tpkg -> do
+ haddockStdOut <- openFile cfgHaddockStdOut WriteMode
handle <- runProcess' cfgHaddockPath $ processConfig
{ pcArgs = concat
[ cfgHaddockArgs
--
cgit v1.2.3
From 391225eea26bb2484cbf49d0ca5964ab3176b974 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
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/src')
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
From 2555cc37c9e9c0eeb9f7fbddb9599bb6fae3e982 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 21 Aug 2015 19:51:24 +0200
Subject: Refactor existing code to use XHTML printer instead of XML one.
---
haddock-test/src/Test/Haddock/Xhtml.hs | 41 +++++++++++++++++-----------------
html-test/Main.hs | 8 +++----
hypsrc-test/Main.hs | 6 ++---
3 files changed, 28 insertions(+), 27 deletions(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
index 21fda36d..69361f7c 100644
--- a/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -3,8 +3,8 @@
module Test.Haddock.Xhtml
- ( Xhtml(..)
- , parseXhtml, dumpXhtml
+ ( Xml(..)
+ , parseXml, dumpXml
, stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter
) where
@@ -13,11 +13,12 @@ import Data.Generics.Aliases
import Data.Generics.Schemes
import Text.XML.Light
-import Text.XHtml
+import Text.XHtml (Html, HtmlAttr, (!))
+import qualified Text.XHtml as Xhtml
-newtype Xhtml = Xhtml
- { xhtmlElement :: Element
+newtype Xml = Xml
+ { xmlElement :: Element
} deriving Eq
@@ -27,19 +28,19 @@ deriving instance Eq Content
deriving instance Eq CData
-parseXhtml :: String -> Maybe Xhtml
-parseXhtml = fmap Xhtml . parseXMLDoc
+parseXml :: String -> Maybe Xml
+parseXml = fmap Xml . parseXMLDoc
-dumpXhtml :: Xhtml -> String
-dumpXhtml = ppElement . xhtmlElement
+dumpXml :: Xml -> String
+dumpXml = Xhtml.renderHtmlFragment. xmlElementToXhtml . xmlElement
-stripLinks :: Xhtml -> Xhtml
+stripLinks :: Xml -> Xml
stripLinks = stripLinksWhen (const True)
-stripLinksWhen :: (String -> Bool) -> Xhtml -> Xhtml
+stripLinksWhen :: (String -> Bool) -> Xml -> Xml
stripLinksWhen p =
processAnchors unlink
where
@@ -48,7 +49,7 @@ stripLinksWhen p =
| otherwise = attr
-stripAnchorsWhen :: (String -> Bool) -> Xhtml -> Xhtml
+stripAnchorsWhen :: (String -> Bool) -> Xml -> Xml
stripAnchorsWhen p =
processAnchors unname
where
@@ -57,13 +58,13 @@ stripAnchorsWhen p =
| otherwise = attr
-processAnchors :: (Attr -> Attr) -> Xhtml -> Xhtml
-processAnchors f = Xhtml . everywhere (mkT f) . xhtmlElement
+processAnchors :: (Attr -> Attr) -> Xml -> Xml
+processAnchors f = Xml . everywhere (mkT f) . xmlElement
-stripFooter :: Xhtml -> Xhtml
+stripFooter :: Xml -> Xml
stripFooter =
- Xhtml . everywhere (mkT defoot) . xhtmlElement
+ Xml . everywhere (mkT defoot) . xmlElement
where
defoot el
| isFooter el = el { elContent = [] }
@@ -77,7 +78,7 @@ stripFooter =
xmlElementToXhtml :: Element -> Html
xmlElementToXhtml (Element { .. }) =
- tag (qName elName) contents ! attrs
+ Xhtml.tag (qName elName) contents ! attrs
where
contents = mconcat $ map xmlContentToXhtml elContent
attrs = map xmlAttrToXhtml elAttribs
@@ -85,9 +86,9 @@ xmlElementToXhtml (Element { .. }) =
xmlContentToXhtml :: Content -> Html
xmlContentToXhtml (Elem el) = xmlElementToXhtml el
-xmlContentToXhtml (Text text) = toHtml $ cdData text
-xmlContentToXhtml (CRef cref) = noHtml
+xmlContentToXhtml (Text text) = Xhtml.toHtml $ cdData text
+xmlContentToXhtml (CRef _) = Xhtml.noHtml
xmlAttrToXhtml :: Attr -> HtmlAttr
-xmlAttrToXhtml (Attr { .. }) = strAttr (qName attrKey) attrVal
+xmlAttrToXhtml (Attr { .. }) = Xhtml.strAttr (qName attrKey) attrVal
diff --git a/html-test/Main.hs b/html-test/Main.hs
index 724d35ec..3880fc3c 100755
--- a/html-test/Main.hs
+++ b/html-test/Main.hs
@@ -10,10 +10,10 @@ import Test.Haddock
import Test.Haddock.Xhtml
-checkConfig :: CheckConfig Xhtml
+checkConfig :: CheckConfig Xml
checkConfig = CheckConfig
- { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXhtml input
- , ccfgDump = dumpXhtml
+ { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXml input
+ , ccfgDump = dumpXml
, ccfgEqual = (==)
}
@@ -32,7 +32,7 @@ main = do
}
-stripIfRequired :: String -> Xhtml -> Xhtml
+stripIfRequired :: String -> Xml -> Xml
stripIfRequired mdl =
stripLinks' . stripFooter
where
diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs
index 06cf8546..0490be47 100644
--- a/hypsrc-test/Main.hs
+++ b/hypsrc-test/Main.hs
@@ -11,10 +11,10 @@ import Test.Haddock
import Test.Haddock.Xhtml
-checkConfig :: CheckConfig Xhtml
+checkConfig :: CheckConfig Xml
checkConfig = CheckConfig
- { ccfgRead = \_ input -> strip <$> parseXhtml input
- , ccfgDump = dumpXhtml
+ { ccfgRead = \_ input -> strip <$> parseXml input
+ , ccfgDump = dumpXml
, ccfgEqual = (==)
}
where
--
cgit v1.2.3
From 27d5cba94e827e10c9f5b02b162f6b13cd8cbea1 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 22 Aug 2015 23:43:16 +0200
Subject: Remove redundant import statement.
---
haddock-test/src/Test/Haddock/Process.hs | 1 -
1 file changed, 1 deletion(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs
index 97f3ebed..ae720f6f 100644
--- a/haddock-test/src/Test/Haddock/Process.hs
+++ b/haddock-test/src/Test/Haddock/Process.hs
@@ -7,7 +7,6 @@ module Test.Haddock.Process where
import Control.Monad
import System.Exit
-import System.FilePath
import System.IO
import System.Process
--
cgit v1.2.3
From 136c48c5fe074ac8a2755c4705d555de24e22a3a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 24 Aug 2015 23:09:20 +0200
Subject: Fix bug with accepting to non-existing directory.
---
haddock-test/src/Test/Haddock.hs | 2 +-
haddock-test/src/Test/Haddock/Utils.hs | 7 +++++++
2 files changed, 8 insertions(+), 1 deletion(-)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 87c16739..e8a0ac8e 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -132,7 +132,7 @@ diffFile cfg diff file = do
maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult
maybeAcceptFile cfg@(Config { cfgDirConfig = dcfg }) file result
| cfgAccept cfg && result `elem` [NoRef, Fail] = do
- copyFile (outFile dcfg file) (refFile dcfg file)
+ copyFile' (outFile dcfg file) (refFile dcfg file)
pure Accepted
maybeAcceptFile _ _ result = pure result
diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs
index 4f97fa72..a947fea1 100644
--- a/haddock-test/src/Test/Haddock/Utils.hs
+++ b/haddock-test/src/Test/Haddock/Utils.hs
@@ -41,3 +41,10 @@ createEmptyDirectory :: FilePath -> IO ()
createEmptyDirectory path = do
whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
createDirectory path
+
+
+-- | Just like 'copyFile' but output directory path is not required to exist.
+copyFile' :: FilePath -> FilePath -> IO ()
+copyFile' old new = do
+ createDirectoryIfMissing True $ takeDirectory new
+ copyFile old new
--
cgit v1.2.3
From 1557c08cac99befbd541dcca4d85c20609518f2b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 25 Aug 2015 17:41:59 +0200
Subject: Fix test suite failure when used with Stack.
---
haddock-test/src/Test/Haddock/Config.hs | 5 +++++
1 file changed, 5 insertions(+)
(limited to 'haddock-test/src')
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index fff84921..8f1f4885 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -213,6 +213,11 @@ printVersions env haddockPath = do
baseDependencies :: FilePath -> IO [String]
baseDependencies ghcPath = do
+ -- The 'getInstalledPackages' crashes if used when "GHC_PACKAGE_PATH" is
+ -- set to some value. I am not sure why is that happening and what are the
+ -- consequences of unsetting it - but looks like it works (for now).
+ unsetEnv "GHC_PACKAGE_PATH"
+
(_, _, cfg) <- configure normal (Just ghcPath) Nothing
defaultProgramConfiguration
pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg
--
cgit v1.2.3