aboutsummaryrefslogtreecommitdiff
path: root/haddock-test/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-test/src')
-rw-r--r--haddock-test/src/Test/Haddock.hs44
-rw-r--r--haddock-test/src/Test/Haddock/Config.hs9
-rw-r--r--haddock-test/src/Test/Haddock/Process.hs14
-rw-r--r--haddock-test/src/Test/Haddock/Xhtml.hs28
4 files changed, 62 insertions, 33 deletions
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 942c0587..25c64cfe 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -34,12 +34,12 @@ data CheckResult
runAndCheck :: Config c -> IO ()
runAndCheck cfg = do
- runHaddock cfg
- checkFiles cfg
+ crashed <- runHaddock cfg
+ checkFiles cfg crashed
-checkFiles :: Config c -> IO ()
-checkFiles cfg@(Config { .. }) = do
+checkFiles :: Config c -> Bool -> IO ()
+checkFiles cfg@(Config { .. }) somethingCrashed = do
putStrLn "Testing output files..."
files <- ignore <$> getDirectoryTree (cfgOutDir cfg)
@@ -54,13 +54,14 @@ checkFiles cfg@(Config { .. }) = do
Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing
Accepted -> putStrLn "ACCEPTED" >> return Nothing
- if null failed
- then do
- putStrLn "All tests passed!"
- exitSuccess
- else do
- maybeDiff cfg failed
- exitFailure
+ if (null failed && not somethingCrashed)
+ then do
+ putStrLn "All tests passed!"
+ exitSuccess
+ else do
+ unless (null failed) $ maybeDiff cfg failed
+ when somethingCrashed $ putStrLn "Some tests crashed."
+ exitFailure
where
ignore = filter (not . dcfgCheckIgnore cfgDirConfig)
@@ -72,12 +73,14 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
forM_ files $ diffFile cfg diff
-runHaddock :: Config c -> IO ()
+-- | Runs Haddock on all of the test packages, and returns whether 'True' if
+-- any of them caused Haddock to crash.
+runHaddock :: Config c -> IO Bool
runHaddock cfg@(Config { .. }) = do
createEmptyDirectory $ cfgOutDir cfg
putStrLn "Generating documentation..."
- forM_ cfgPackages $ \tpkg -> do
+ successes <- forM cfgPackages $ \tpkg -> do
haddockStdOut <- openFile cfgHaddockStdOut WriteMode
let pc = processConfig
{ pcArgs = concat
@@ -87,9 +90,20 @@ runHaddock cfg@(Config { .. }) = do
]
, pcEnv = Just $ cfgEnv
, pcStdOut = Just $ haddockStdOut
+ , pcStdErr = Just $ haddockStdOut
}
- handle <- runProcess' cfgHaddockPath pc
- waitForSuccess "Failed to run Haddock on specified test files" handle
+
+ let msg = "Failed to run Haddock on test package '" ++ tpkgName tpkg ++ "'"
+ succeeded <- waitForSuccess msg stdout =<< runProcess' cfgHaddockPath pc
+ unless succeeded $ removeDirectoryRecursive (outDir cfgDirConfig tpkg)
+
+ pure succeeded
+
+ let somethingFailed = any not successes
+ when somethingFailed $
+ putStrLn ("Haddock output is at '" ++ cfgHaddockStdOut ++ "'. " ++
+ "This file can be set with `--haddock-stdout`.")
+ pure somethingFailed
checkFile :: Config c -> FilePath -> IO CheckResult
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 51032a3a..51394eff 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -196,6 +196,7 @@ loadConfig ccfg dcfg flags files = do
cfgHaddockArgs <- liftM concat . sequence $
[ pure ["--no-warnings"]
+ , pure ["--bypass-interface-version-check"]
, pure ["--odir=" ++ dcfgOutDir dcfg]
, pure ["--optghc=-w"]
, pure ["--optghc=-hide-all-packages"]
@@ -223,13 +224,13 @@ printVersions env haddockPath = do
{ pcEnv = Just env
, pcArgs = ["--version"]
}
- waitForSuccess "Failed to run `haddock --version`" handleHaddock
+ void $ waitForSuccess "Failed to run `haddock --version`" stderr handleHaddock
handleGhc <- runProcess' haddockPath $ processConfig
{ pcEnv = Just env
, pcArgs = ["--ghc-version"]
}
- waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc
+ void $ waitForSuccess "Failed to run `haddock --ghc-version`" stderr handleGhc
baseDependencies :: FilePath -> IO [String]
@@ -240,7 +241,7 @@ baseDependencies ghcPath = do
unsetEnv "GHC_PACKAGE_PATH"
(comp, _, cfg) <- configure normal (Just ghcPath) Nothing
- defaultProgramConfiguration
+ defaultProgramDb
#if MIN_VERSION_Cabal(1,23,0)
pkgIndex <- getInstalledPackages normal comp [GlobalPackageDB] cfg
#else
@@ -300,7 +301,7 @@ defaultDiffTool :: IO (Maybe FilePath)
defaultDiffTool =
liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"]
where
- isAvailable = liftM isJust . findProgramLocation silent
+ isAvailable = liftM isJust . findExecutable
defaultStdOut :: FilePath
diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs
index 52bf9533..a6cab9ac 100644
--- a/haddock-test/src/Test/Haddock/Process.hs
+++ b/haddock-test/src/Test/Haddock/Process.hs
@@ -40,10 +40,10 @@ 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
+-- | Wait for a process to finish running. If it ends up failing, print out the
+-- error message.
+waitForSuccess :: String -> Handle -> ProcessHandle -> IO Bool
+waitForSuccess msg out handle = do
+ succeeded <- fmap (== ExitSuccess) $ waitForProcess handle
+ unless succeeded $ hPutStrLn out msg
+ pure succeeded
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
index 8bfc973f..6c19dbca 100644
--- a/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -1,17 +1,17 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Haddock.Xhtml
( Xml(..)
, parseXml, dumpXml
- , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter
+ , stripLinks, stripLinksWhen, stripAnchorsWhen, stripIdsWhen, stripFooter
) where
-
-import Data.Generics.Aliases
-import Data.Generics.Schemes
-
+import Data.Data ( Data(..), Typeable, eqT, (:~:)(..) )
import Text.XML.Light
import Text.XHtml (Html, HtmlAttr, (!))
import qualified Text.XHtml as Xhtml
@@ -26,6 +26,12 @@ deriving instance Eq Element
deriving instance Eq Content
deriving instance Eq CData
+-- | Similar to @everywhere (mkT f) x@ from SYB.
+gmapEverywhere :: forall a b. (Data a, Typeable b) => (b -> b) -> a -> a
+gmapEverywhere f x = gmapT (gmapEverywhere f) $ case eqT @a @b of
+ Nothing -> x
+ Just Refl -> f x
+
parseXml :: String -> Maybe Xml
parseXml = fmap Xml . parseXMLDoc
@@ -56,14 +62,22 @@ stripAnchorsWhen p =
| qName key == "name" && p val = attr { attrVal = "" }
| otherwise = attr
+stripIdsWhen :: (String -> Bool) -> Xml -> Xml
+stripIdsWhen p =
+ processAnchors unname
+ where
+ unname attr@(Attr { attrKey = key, attrVal = val })
+ | qName key == "id" && p val = attr { attrVal = "" }
+ | otherwise = attr
+
processAnchors :: (Attr -> Attr) -> Xml -> Xml
-processAnchors f = Xml . everywhere (mkT f) . xmlElement
+processAnchors f = Xml . gmapEverywhere f . xmlElement
stripFooter :: Xml -> Xml
stripFooter =
- Xml . everywhere (mkT defoot) . xmlElement
+ Xml . gmapEverywhere defoot . xmlElement
where
defoot el
| isFooter el = el { elContent = [] }
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 02:53:24 +0000