aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore2
-rw-r--r--.travis.yml2
-rw-r--r--README.md45
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs3
-rw-r--r--haddock-test/haddock-test.cabal28
-rw-r--r--haddock-test/src/Test/Haddock.hs149
-rw-r--r--haddock-test/src/Test/Haddock/Config.hs282
-rw-r--r--haddock-test/src/Test/Haddock/Process.hs48
-rw-r--r--haddock-test/src/Test/Haddock/Utils.hs50
-rw-r--r--haddock-test/src/Test/Haddock/Xhtml.hs94
-rw-r--r--haddock.cabal19
-rw-r--r--hoogle-test/Main.hs31
-rw-r--r--hoogle-test/ref/assoc-types/test.txt14
-rw-r--r--hoogle-test/ref/classes/test.txt17
-rw-r--r--hoogle-test/ref/fixity/test.txt13
-rw-r--r--hoogle-test/ref/modules/test.txt13
-rwxr-xr-xhoogle-test/run6
-rw-r--r--hoogle-test/src/assoc-types/AssocTypes.hs23
-rw-r--r--hoogle-test/src/classes/Classes.hs16
-rw-r--r--hoogle-test/src/fixity/Fixity.hs12
-rw-r--r--hoogle-test/src/modules/Bar.hs12
-rw-r--r--hoogle-test/src/modules/Foo.hs9
-rwxr-xr-xhtml-test/Main.hs51
-rw-r--r--html-test/README.markdown27
-rwxr-xr-xhtml-test/accept.lhs49
-rwxr-xr-xhtml-test/run6
-rwxr-xr-xhtml-test/run.lhs191
-rw-r--r--hypsrc-test/Main.hs50
-rw-r--r--hypsrc-test/Utils.hs47
-rwxr-xr-xhypsrc-test/accept.hs27
-rwxr-xr-xhypsrc-test/run6
-rwxr-xr-xhypsrc-test/run.hs122
-rwxr-xr-xlatex-test/Main.hs27
-rwxr-xr-xlatex-test/accept.lhs46
-rw-r--r--latex-test/ref/Simple/Simple.tex3
-rwxr-xr-xlatex-test/run6
-rwxr-xr-xlatex-test/run.lhs162
37 files changed, 1017 insertions, 691 deletions
diff --git a/.gitignore b/.gitignore
index 3c9798c1..2bbb0885 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,9 +1,11 @@
/dist/
/haddock-api/dist/
/haddock-library/dist/
+/haddock-test/dist/
/html-test/out/
/hypsrc-test/out/
/latex-test/out/
+/hoogle-test/out/
/doc/haddock
/doc/haddock.ps
diff --git a/.travis.yml b/.travis.yml
index c16b1709..585b0b25 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -22,6 +22,8 @@ before_install:
- cabal install
- cd ..
- (cd haddock-api/ && cabal install --only-dependencies --enable-tests && cabal configure --enable-tests && cabal build && cabal test && cabal install)
+ - (cd haddock-test/ && cabal install --only-dependencies && cabal configure && cabal build && cabal install)
script:
+ - export HADDOCK_PATH="dist/build/haddock/haddock"
- cabal configure --enable-tests && cabal build && cabal test
diff --git a/README.md b/README.md
index 31015e91..160ee995 100644
--- a/README.md
+++ b/README.md
@@ -46,25 +46,46 @@ format.
Please create issues when you have any problems and pull requests if you have some code.
-###### Hacking
+##### Hacking
-To get started you'll need a latest GHC release installed. Below is an
-example setup using cabal sandboxes.
+To get started you'll need a latest GHC release installed.
+
+Clone the repository:
```bash
git clone https://github.com/haskell/haddock.git
cd haddock
- cabal sandbox init
- cabal sandbox add-source haddock-library
- cabal sandbox add-source haddock-api
- # adjust -j to the number of cores you want to use
- cabal install -j4 --dependencies-only --enable-tests
- cabal configure --enable-tests
- cabal build -j4
- # run the test suite
- cabal test
```
+and then proceed using your favourite build tool.
+
+###### Using Cabal sandboxes
+
+```bash
+cabal sandbox init
+cabal sandbox add-source haddock-library
+cabal sandbox add-source haddock-api
+cabal sandbox add-source haddock-test
+# adjust -j to the number of cores you want to use
+cabal install -j4 --dependencies-only --enable-tests
+cabal configure --enable-tests
+cabal build -j4
+# run the test suite
+export HADDOCK_PATH="dist/build/haddock/haddock"
+cabal test
+```
+
+###### Using Stack
+
+```bash
+stack init
+stack install
+# run the test suite
+export HADDOCK_PATH="$HOME/.local/bin/haddock"
+stack test
+```
+
+
If you're a GHC developer and want to update Haddock to work with your
changes, you should be working on `ghc-head` branch instead of master.
See instructions at
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index a9bc9a8b..f3749a85 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -29,6 +29,8 @@ import Data.Char
import Data.List
import Data.Maybe
import Data.Version
+
+import System.Directory
import System.FilePath
import System.IO
@@ -47,6 +49,7 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
["@version " ++ showVersion version
| not (null (versionBranch version)) ] ++
concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+ createDirectoryIfMissing True odir
h <- openFile (odir </> filename) WriteMode
hSetEncoding h utf8
hPutStr h (unlines contents)
diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal
new file mode 100644
index 00000000..0394da8f
--- /dev/null
+++ b/haddock-test/haddock-test.cabal
@@ -0,0 +1,28 @@
+name: haddock-test
+version: 0.0.1
+synopsis: Test utilities for Haddock
+license: BSD3
+author: Simon Marlow, David Waern
+maintainer: Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
+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
+ ghc-options: -Wall
+ hs-source-dirs: src
+ build-depends: base, directory, process, filepath, Cabal, xml, xhtml, syb
+
+ exposed-modules:
+ Test.Haddock
+ Test.Haddock.Config
+ 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
new file mode 100644
index 00000000..e8a0ac8e
--- /dev/null
+++ b/haddock-test/src/Test/Haddock.hs
@@ -0,0 +1,149 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Test.Haddock
+ ( module Test.Haddock.Config
+ , runAndCheck, runHaddock, checkFiles
+ ) 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.Utils
+
+
+data CheckResult
+ = Fail
+ | Pass
+ | NoRef
+ | Error String
+ | Accepted
+ deriving Eq
+
+
+runAndCheck :: Config c -> IO ()
+runAndCheck cfg = do
+ runHaddock cfg
+ checkFiles cfg
+
+
+checkFiles :: Config c -> IO ()
+checkFiles cfg@(Config { .. }) = do
+ putStrLn "Testing output files..."
+
+ files <- ignore <$> getDirectoryTree (cfgOutDir cfg)
+ failed <- liftM catMaybes . forM files $ \file -> do
+ putStr $ "Checking \"" ++ 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
+ putStrLn "All tests passed!"
+ exitSuccess
+ else do
+ maybeDiff cfg failed
+ exitFailure
+ where
+ ignore = filter (not . dcfgCheckIgnore cfgDirConfig)
+
+
+maybeDiff :: Config c -> [FilePath] -> IO ()
+maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure ()
+maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
+ putStrLn "Diffing failed cases..."
+ forM_ files $ diffFile cfg diff
+
+
+runHaddock :: Config c -> IO ()
+runHaddock cfg@(Config { .. }) = do
+ createEmptyDirectory $ cfgOutDir cfg
+
+ putStrLn "Generating documentation..."
+ forM_ cfgPackages $ \tpkg -> do
+ haddockStdOut <- openFile cfgHaddockStdOut WriteMode
+ 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 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
+ | otherwise -> Fail
+ _ -> Error "Failed to parse input files"
+ else return NoRef
+ where
+ ccfg = cfgCheckConfig cfg
+ dcfg = cfgDirConfig cfg
+
+
+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 file \"" ++ file ++ "\":"
+ hFlush stdout
+ handle <- runProcess' diff $ processConfig
+ { pcArgs = [outFile', refFile']
+ , pcStdOut = Just $ stdout
+ }
+ waitForProcess handle >> return ()
+ where
+ dcfg = cfgDirConfig cfg
+ ccfg = cfgCheckConfig cfg
+ outFile' = outFile dcfg file <.> "dump"
+ 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
+
+
+outFile :: DirConfig -> FilePath -> FilePath
+outFile dcfg file = dcfgOutDir dcfg </> file
+
+
+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
new file mode 100644
index 00000000..8f1f4885
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -0,0 +1,282 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Test.Haddock.Config
+ ( TestPackage(..), CheckConfig(..), DirConfig(..), Config(..)
+ , defaultDirConfig
+ , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir
+ , parseArgs, checkOpt, loadConfig
+ ) 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
+
+
+data TestPackage = TestPackage
+ { tpkgName :: String
+ , tpkgFiles :: [FilePath]
+ }
+
+
+data CheckConfig c = CheckConfig
+ { ccfgRead :: String -> String -> Maybe c
+ , ccfgDump :: c -> String
+ , ccfgEqual :: c -> c -> Bool
+ }
+
+
+data DirConfig = DirConfig
+ { dcfgSrcDir :: FilePath
+ , dcfgRefDir :: FilePath
+ , dcfgOutDir :: FilePath
+ , dcfgResDir :: FilePath
+ , dcfgCheckIgnore :: FilePath -> Bool
+ }
+
+
+defaultDirConfig :: FilePath -> DirConfig
+defaultDirConfig baseDir = DirConfig
+ { dcfgSrcDir = baseDir </> "src"
+ , dcfgRefDir = baseDir </> "ref"
+ , dcfgOutDir = baseDir </> "out"
+ , dcfgResDir = rootDir </> "resources"
+ , dcfgCheckIgnore = const False
+ }
+ where
+ rootDir = baseDir </> ".."
+
+
+data Config c = Config
+ { cfgHaddockPath :: FilePath
+ , cfgPackages :: [TestPackage]
+ , cfgHaddockArgs :: [String]
+ , cfgHaddockStdOut :: FilePath
+ , cfgDiffTool :: Maybe FilePath
+ , cfgEnv :: Environment
+ , cfgAccept :: Bool
+ , cfgCheckConfig :: CheckConfig c
+ , cfgDirConfig :: DirConfig
+ }
+
+
+cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config c -> FilePath
+cfgSrcDir = dcfgSrcDir . cfgDirConfig
+cfgRefDir = dcfgRefDir . cfgDirConfig
+cfgOutDir = dcfgOutDir . cfgDirConfig
+cfgResDir = dcfgResDir . cfgDirConfig
+
+
+
+data Flag
+ = FlagHaddockPath FilePath
+ | FlagHaddockOptions String
+ | FlagHaddockStdOut FilePath
+ | FlagDiffTool FilePath
+ | FlagNoDiff
+ | FlagAccept
+ | FlagHelp
+ deriving Eq
+
+
+flagsHaddockPath :: [Flag] -> Maybe FilePath
+flagsHaddockPath flags = mlast [ path | FlagHaddockPath 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 [] ["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 ['a'] ["accept"] (NoArg FlagAccept)
+ "accept generated output"
+ , Option [] ["no-diff"] (NoArg FlagNoDiff)
+ "do not print diff for failed cases"
+ , Option ['h'] ["help"] (NoArg FlagHelp)
+ "display this help end exit"
+ ]
+
+
+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
+
+ unless (null errors) $ do
+ hPutStr stderr $ concat errors
+ exitFailure
+
+ when (FlagHelp `elem` flags) $ do
+ hPutStrLn stderr $ usageInfo "" options
+ exitSuccess
+
+ return (flags, files)
+
+
+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
+ Just path -> pure path
+ Nothing -> do
+ hPutStrLn stderr $ "Haddock executable not specified"
+ exitFailure
+
+ ghcPath <- init <$> rawSystemStdout normal cfgHaddockPath
+ ["--print-ghc-path"]
+
+ printVersions cfgEnv cfgHaddockPath
+
+ cfgPackages <- processFileArgs dcfg files
+
+ cfgHaddockArgs <- liftM concat . sequence $
+ [ pure ["--no-warnings"]
+ , pure ["--odir=" ++ dcfgOutDir dcfg]
+ , 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
+
+ let cfgAccept = FlagAccept `elem` flags
+
+ let cfgCheckConfig = ccfg
+ let cfgDirConfig = dcfg
+
+ 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
+ -- 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
+ 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 [TestPackage]
+processFileArgs dcfg [] =
+ processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir
+ where
+ isValidEntry entry
+ | hasExtension entry = isSourceFile entry
+ | otherwise = isRealDir entry
+ srcDir = dcfgSrcDir dcfg
+processFileArgs dcfg args = processFileArgs' dcfg args
+
+
+processFileArgs' :: DirConfig -> [String] -> IO [TestPackage]
+processFileArgs' dcfg args = do
+ (dirs, mdls) <- partitionM doesDirectoryExist' . map takeBaseName $ args
+ rootPkg <- pure $ TestPackage
+ { tpkgName = ""
+ , tpkgFiles = map (srcDir </>) mdls
+ }
+ otherPkgs <- forM dirs $ \dir -> do
+ let srcDir' = srcDir </> dir
+ files <- filterM (isModule dir) =<< getDirectoryContents srcDir'
+ pure $ TestPackage
+ { tpkgName = dir
+ , tpkgFiles = map (srcDir' </>) files
+ }
+ pure . filter (not . null . tpkgFiles) $ rootPkg:otherPkgs
+ where
+ doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
+ isModule dir file = (isSourceFile file &&) <$>
+ doesFileExist (srcDir </> dir </> file)
+ srcDir = dcfgSrcDir dcfg
+
+
+isSourceFile :: FilePath -> Bool
+isSourceFile file = takeExtension file `elem` [".hs", ".lhs"]
+
+
+isRealDir :: FilePath -> Bool
+isRealDir dir = not $ dir `elem` [".", ".."]
diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs
new file mode 100644
index 00000000..ae720f6f
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Process.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Test.Haddock.Process where
+
+
+import Control.Monad
+
+import System.Exit
+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..a947fea1
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Utils.hs
@@ -0,0 +1,50 @@
+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)
+
+
+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
+ 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 == ".."
+
+
+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
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
new file mode 100644
index 00000000..69361f7c
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+
+module Test.Haddock.Xhtml
+ ( Xml(..)
+ , parseXml, dumpXml
+ , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter
+ ) where
+
+
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+
+import Text.XML.Light
+import Text.XHtml (Html, HtmlAttr, (!))
+import qualified Text.XHtml as Xhtml
+
+
+newtype Xml = Xml
+ { xmlElement :: 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
+
+
+parseXml :: String -> Maybe Xml
+parseXml = fmap Xml . parseXMLDoc
+
+
+dumpXml :: Xml -> String
+dumpXml = Xhtml.renderHtmlFragment. xmlElementToXhtml . xmlElement
+
+
+stripLinks :: Xml -> Xml
+stripLinks = stripLinksWhen (const True)
+
+
+stripLinksWhen :: (String -> Bool) -> Xml -> Xml
+stripLinksWhen p =
+ processAnchors unlink
+ where
+ unlink attr@(Attr { attrKey = key, attrVal = val })
+ | qName key == "href" && p val = attr { attrVal = "#" }
+ | otherwise = attr
+
+
+stripAnchorsWhen :: (String -> Bool) -> Xml -> Xml
+stripAnchorsWhen p =
+ processAnchors unname
+ where
+ unname attr@(Attr { attrKey = key, attrVal = val })
+ | qName key == "name" && p val = attr { attrVal = "" }
+ | otherwise = attr
+
+
+processAnchors :: (Attr -> Attr) -> Xml -> Xml
+processAnchors f = Xml . everywhere (mkT f) . xmlElement
+
+
+stripFooter :: Xml -> Xml
+stripFooter =
+ Xml . everywhere (mkT defoot) . xmlElement
+ where
+ defoot el
+ | isFooter el = el { elContent = [] }
+ | otherwise = el
+ isFooter el = any isFooterAttr $ elAttribs el
+ isFooterAttr (Attr { .. }) = and
+ [ qName attrKey == "id"
+ , attrVal == "footer"
+ ]
+
+
+xmlElementToXhtml :: Element -> Html
+xmlElementToXhtml (Element { .. }) =
+ Xhtml.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) = Xhtml.toHtml $ cdData text
+xmlContentToXhtml (CRef _) = Xhtml.noHtml
+
+
+xmlAttrToXhtml :: Attr -> HtmlAttr
+xmlAttrToXhtml (Attr { .. }) = Xhtml.strAttr (qName attrKey) attrVal
diff --git a/haddock.cabal b/haddock.cabal
index ec2a43bc..294e1526 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -126,24 +126,31 @@ executable haddock
test-suite html-test
type: exitcode-stdio-1.0
default-language: Haskell2010
- main-is: run.lhs
+ main-is: Main.hs
hs-source-dirs: html-test
- build-depends: base, directory, process, filepath, Cabal
+ build-depends: base, filepath, haddock-test
test-suite hypsrc-test
type: exitcode-stdio-1.0
default-language: Haskell2010
- main-is: run.hs
+ main-is: Main.hs
hs-source-dirs: hypsrc-test
- build-depends: base, directory, process, filepath, Cabal
+ build-depends: base, filepath, haddock-test
ghc-options: -Wall -fwarn-tabs
test-suite latex-test
type: exitcode-stdio-1.0
default-language: Haskell2010
- main-is: run.lhs
+ main-is: Main.hs
hs-source-dirs: latex-test
- build-depends: base, directory, process, filepath, Cabal
+ build-depends: base, filepath, haddock-test
+
+test-suite hoogle-test
+ type: exitcode-stdio-1.0
+ default-language: Haskell2010
+ main-is: Main.hs
+ hs-source-dirs: hoogle-test
+ build-depends: base, filepath, haddock-test
source-repository head
type: git
diff --git a/hoogle-test/Main.hs b/hoogle-test/Main.hs
new file mode 100644
index 00000000..c8cda640
--- /dev/null
+++ b/hoogle-test/Main.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE CPP #-}
+
+
+import System.Environment
+import System.FilePath
+
+import Test.Haddock
+
+
+checkConfig :: CheckConfig String
+checkConfig = CheckConfig
+ { ccfgRead = \_ input -> Just input
+ , ccfgDump = id
+ , ccfgEqual = (==)
+ }
+
+
+dirConfig :: DirConfig
+dirConfig = defaultDirConfig $ takeDirectory __FILE__
+
+
+main :: IO ()
+main = do
+ cfg <- parseArgs checkConfig dirConfig =<< getArgs
+ runAndCheck $ cfg
+ { cfgHaddockArgs = cfgHaddockArgs cfg ++
+ [ "--package-name=test"
+ , "--package-version=0.0.0"
+ , "--hoogle"
+ ]
+ }
diff --git a/hoogle-test/ref/assoc-types/test.txt b/hoogle-test/ref/assoc-types/test.txt
new file mode 100644
index 00000000..ba1a145a
--- /dev/null
+++ b/hoogle-test/ref/assoc-types/test.txt
@@ -0,0 +1,14 @@
+-- Hoogle documentation, generated by Haddock
+-- See Hoogle, http://www.haskell.org/hoogle/
+
+@package test
+@version 0.0.0
+
+module AssocTypes
+class Foo a where {
+ type family Bar a b;
+ type family Baz a;
+ type Baz a = [(a, a)];
+}
+bar :: Foo a => Bar a a
+instance AssocTypes.Foo [a]
diff --git a/hoogle-test/ref/classes/test.txt b/hoogle-test/ref/classes/test.txt
new file mode 100644
index 00000000..69f224eb
--- /dev/null
+++ b/hoogle-test/ref/classes/test.txt
@@ -0,0 +1,17 @@
+-- Hoogle documentation, generated by Haddock
+-- See Hoogle, http://www.haskell.org/hoogle/
+
+@package test
+@version 0.0.0
+
+module Classes
+class Foo f
+bar :: Foo f => f a -> f b -> f (a, b)
+baz :: Foo f => f ()
+class Quux q
+(+++) :: Quux q => q -> q -> q
+(///) :: Quux q => q -> q -> q
+(***) :: Quux q => q -> q -> q
+logBase :: Quux q => q -> q -> q
+foo :: Quux q => q -> q -> q
+quux :: Quux q => q -> q -> q
diff --git a/hoogle-test/ref/fixity/test.txt b/hoogle-test/ref/fixity/test.txt
new file mode 100644
index 00000000..6f609539
--- /dev/null
+++ b/hoogle-test/ref/fixity/test.txt
@@ -0,0 +1,13 @@
+-- Hoogle documentation, generated by Haddock
+-- See Hoogle, http://www.haskell.org/hoogle/
+
+@package test
+@version 0.0.0
+
+module Fixity
+(+++) :: a -> a -> a
+infix 6 +++
+(***) :: a -> a -> a
+infixl 7 ***
+(///) :: a -> a -> a
+infixr 8 ///
diff --git a/hoogle-test/ref/modules/test.txt b/hoogle-test/ref/modules/test.txt
new file mode 100644
index 00000000..6705b790
--- /dev/null
+++ b/hoogle-test/ref/modules/test.txt
@@ -0,0 +1,13 @@
+-- Hoogle documentation, generated by Haddock
+-- See Hoogle, http://www.haskell.org/hoogle/
+
+@package test
+@version 0.0.0
+
+module Foo
+foo :: Int -> Int
+foo' :: Int -> Int -> Int
+
+module Bar
+bar :: Int -> Int
+bar' :: Int -> Int -> Int
diff --git a/hoogle-test/run b/hoogle-test/run
new file mode 100755
index 00000000..3e72be80
--- /dev/null
+++ b/hoogle-test/run
@@ -0,0 +1,6 @@
+#!/usr/bin/env bash
+
+export HADDOCK_PATH=$(which haddock)
+LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/"
+MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs"
+runhaskell -i:"$LIB_PATH" $MAIN_PATH $@
diff --git a/hoogle-test/src/assoc-types/AssocTypes.hs b/hoogle-test/src/assoc-types/AssocTypes.hs
new file mode 100644
index 00000000..a9bdc6d8
--- /dev/null
+++ b/hoogle-test/src/assoc-types/AssocTypes.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE TypeFamilies #-}
+
+
+module AssocTypes where
+
+
+class Foo a where
+
+ type Bar a b
+ type Baz a
+
+ type Baz a = [(a, a)]
+
+ bar :: Bar a a
+ bar = undefined
+
+
+instance Foo [a] where
+
+ type Bar [a] Int = [(a, Bool)]
+ type Bar [a] Bool = [(Int, a)]
+
+ type Baz [a] = (a, a, a)
diff --git a/hoogle-test/src/classes/Classes.hs b/hoogle-test/src/classes/Classes.hs
new file mode 100644
index 00000000..23f68499
--- /dev/null
+++ b/hoogle-test/src/classes/Classes.hs
@@ -0,0 +1,16 @@
+module Classes where
+
+
+class Foo f where
+
+ bar :: f a -> f b -> f (a, b)
+ baz :: f ()
+
+ baz = undefined
+
+
+class Quux q where
+
+ (+++), (///) :: q -> q -> q
+ (***), logBase :: q -> q -> q
+ foo, quux :: q -> q -> q
diff --git a/hoogle-test/src/fixity/Fixity.hs b/hoogle-test/src/fixity/Fixity.hs
new file mode 100644
index 00000000..3af38117
--- /dev/null
+++ b/hoogle-test/src/fixity/Fixity.hs
@@ -0,0 +1,12 @@
+module Fixity where
+
+
+(+++), (***), (///) :: a -> a -> a
+(+++) = undefined
+(***) = undefined
+(///) = undefined
+
+
+infix 6 +++
+infixl 7 ***
+infixr 8 ///
diff --git a/hoogle-test/src/modules/Bar.hs b/hoogle-test/src/modules/Bar.hs
new file mode 100644
index 00000000..156a835f
--- /dev/null
+++ b/hoogle-test/src/modules/Bar.hs
@@ -0,0 +1,12 @@
+module Bar where
+
+
+import Foo
+
+
+bar :: Int -> Int
+bar x = foo' x x
+
+
+bar' :: Int -> Int -> Int
+bar' x y = foo' (bar (foo x)) (bar (foo y))
diff --git a/hoogle-test/src/modules/Foo.hs b/hoogle-test/src/modules/Foo.hs
new file mode 100644
index 00000000..6581fe4c
--- /dev/null
+++ b/hoogle-test/src/modules/Foo.hs
@@ -0,0 +1,9 @@
+module Foo where
+
+
+foo :: Int -> Int
+foo = (* 2)
+
+
+foo' :: Int -> Int -> Int
+foo' x y = foo x + foo y
diff --git a/html-test/Main.hs b/html-test/Main.hs
new file mode 100755
index 00000000..3880fc3c
--- /dev/null
+++ b/html-test/Main.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP #-}
+
+
+import Data.Char
+
+import System.Environment
+import System.FilePath
+
+import Test.Haddock
+import Test.Haddock.Xhtml
+
+
+checkConfig :: CheckConfig Xml
+checkConfig = CheckConfig
+ { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXml input
+ , ccfgDump = dumpXml
+ , ccfgEqual = (==)
+ }
+
+
+dirConfig :: DirConfig
+dirConfig = (defaultDirConfig $ takeDirectory __FILE__)
+ { dcfgCheckIgnore = checkIgnore
+ }
+
+
+main :: IO ()
+main = do
+ cfg <- parseArgs checkConfig dirConfig =<< getArgs
+ runAndCheck $ cfg
+ { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--pretty-html", "--html"]
+ }
+
+
+stripIfRequired :: String -> Xml -> Xml
+stripIfRequired mdl =
+ stripLinks' . stripFooter
+ where
+ stripLinks'
+ | mdl `elem` preserveLinksModules = id
+ | otherwise = stripLinks
+
+
+-- | List of modules in which we don't 'stripLinks'
+preserveLinksModules :: [String]
+preserveLinksModules = ["Bug253"]
+
+
+checkIgnore :: FilePath -> Bool
+checkIgnore file@(c:_) | takeExtension file == ".html" && isUpper c = False
+checkIgnore _ = True
diff --git a/html-test/README.markdown b/html-test/README.markdown
deleted file mode 100644
index 717bac5c..00000000
--- a/html-test/README.markdown
+++ /dev/null
@@ -1,27 +0,0 @@
-This is a testsuite for Haddock that uses the concept of "golden files". That
-is, it compares output files against a set of reference files.
-
-To add a new test:
-
- 1. Create a module in the `html-test/src` directory.
-
- 2. Run `cabal test`. You should now have `html-test/out/<modulename>.html`.
- The test passes since there is no reference file to compare with.
-
- 3. To make a reference file from the output file, run
-
- html-test/accept.lhs <modulename>
-
-Tips and tricks:
-
-To "accept" all output files (copy them to reference files), run
-
- runhaskell accept.lhs
-
-You can run all tests despite failing tests, like so
-
- cabal test --test-option=all
-
-You can pass extra options to haddock like so
-
- cabal test --test-options='all --title="All Tests"'
diff --git a/html-test/accept.lhs b/html-test/accept.lhs
deleted file mode 100755
index f6dfc4cd..00000000
--- a/html-test/accept.lhs
+++ /dev/null
@@ -1,49 +0,0 @@
-#!/usr/bin/env runhaskell
-\begin{code}
-{-# LANGUAGE CPP #-}
-import System.Cmd
-import System.Environment
-import System.FilePath
-import System.Directory
-import Data.List
-import Control.Applicative
-
-baseDir = takeDirectory __FILE__
-
-main :: IO ()
-main = do
- contents <- filter (not . ignore) <$> getDirectoryContents (baseDir </> "out")
- args <- getArgs
- if not $ null args then
- mapM_ copy [ baseDir </> "out" </> file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ]
- else
- mapM_ copy [ baseDir </> "out" </> file | file <- contents]
- where
- ignore =
- foldr (liftA2 (||)) (const False) [
- (== ".")
- , (== "..")
- , (isPrefixOf "index")
- , (isPrefixOf "doc-index")
- ]
-
-copy :: FilePath -> IO ()
-copy file = do
- let new = baseDir </> "ref" </> takeFileName file
- if ".html" `isSuffixOf` file then do
- putStrLn (file ++ " -> " ++ new)
- stripLinks <$> readFile file >>= writeFile new
- else do
- -- copy css, images, etc.
- copyFile file new
-
-stripLinks :: String -> String
-stripLinks str =
- let prefix = "<a href=\"" in
- case stripPrefix prefix str of
- Just str' -> prefix ++ stripLinks (dropWhile (/= '"') str')
- Nothing ->
- case str of
- [] -> []
- x : xs -> x : stripLinks xs
-\end{code}
diff --git a/html-test/run b/html-test/run
new file mode 100755
index 00000000..3e72be80
--- /dev/null
+++ b/html-test/run
@@ -0,0 +1,6 @@
+#!/usr/bin/env bash
+
+export HADDOCK_PATH=$(which haddock)
+LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/"
+MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs"
+runhaskell -i:"$LIB_PATH" $MAIN_PATH $@
diff --git a/html-test/run.lhs b/html-test/run.lhs
deleted file mode 100755
index 1f19b723..00000000
--- a/html-test/run.lhs
+++ /dev/null
@@ -1,191 +0,0 @@
-#!/usr/bin/env runhaskell
-\begin{code}
-{-# LANGUAGE CPP #-}
-import Prelude hiding (mod)
-import Control.Monad
-import Control.Applicative
-import Data.List
-import Data.Maybe
-import Distribution.InstalledPackageInfo
-import Distribution.Package (PackageName (..))
-import Distribution.Simple.Compiler
-import Distribution.Simple.GHC
-import Distribution.Simple.PackageIndex
-import Distribution.Simple.Program
-import Distribution.Simple.Utils
-import Distribution.Verbosity
-import System.IO
-import System.Directory
-import System.Environment
-import System.Exit
-import System.FilePath
-import System.Process (ProcessHandle, runProcess, waitForProcess, system)
-
-packageRoot, dataDir, haddockPath, baseDir, testDir, outDir :: FilePath
-baseDir = takeDirectory __FILE__
-testDir = baseDir </> "src"
-refDir = baseDir </> "ref"
-outDir = baseDir </> "out"
-packageRoot = baseDir </> ".."
-dataDir = packageRoot </> "resources"
-haddockPath = packageRoot </> "dist" </> "build" </> "haddock" </> "haddock"
-
-
-main :: IO ()
-main = do
- test
- putStrLn "All tests passed!"
-
-
-test :: IO ()
-test = do
- x <- doesFileExist haddockPath
- unless x $ System.Exit.die "you need to run 'cabal build' successfully first"
-
- contents <- getDirectoryContents testDir
- args <- getArgs
- let (opts, spec) = span ("-" `isPrefixOf`) args
- let mods =
- case spec of
- y:_ | y /= "all" -> [y ++ ".hs"]
- _ -> filter ((==) ".hs" . takeExtension) contents
-
- let mods' = map (testDir </>) mods
-
- -- add haddock_datadir to environment for subprocesses
- env <- Just . (:) ("haddock_datadir", Main.dataDir) <$> getEnvironment
-
- putStrLn ""
- putStrLn "Haddock version: "
- h1 <- runProcess haddockPath ["--version"] Nothing
- env Nothing Nothing Nothing
- wait h1 "*** Running `haddock --version' failed!"
- putStrLn ""
- putStrLn "GHC version: "
- h2 <- runProcess haddockPath ["--ghc-version"] Nothing
- env Nothing Nothing Nothing
- wait h2 "*** Running `haddock --ghc-version' failed!"
- putStrLn ""
-
- -- TODO: maybe do something more clever here using haddock.cabal
- ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"]
- (_, _, conf) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration
- pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf
- let mkDep pkgName =
- fromMaybe (error "Couldn't find test dependencies") $ do
- let pkgs = lookupPackageName pkgIndex (PackageName pkgName)
- (_, pkgs') <- listToMaybe pkgs
- pkg <- listToMaybe pkgs'
- ifacePath <- listToMaybe (haddockInterfaces pkg)
- htmlPath <- listToMaybe (haddockHTMLs pkg)
- return ("-i " ++ htmlPath ++ "," ++ ifacePath)
-
- let base = mkDep "base"
- process = mkDep "process"
- ghcprim = mkDep "ghc-prim"
-
- putStrLn "Running tests..."
- handle <- runProcess haddockPath
- (["-w", "-o", outDir, "-h", "--pretty-html"
- , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
- Nothing env Nothing
- Nothing Nothing
-
- wait handle "*** Haddock run failed! Exiting."
- check mods (if not (null args) && args !! 0 == "all" then False else True)
- where
- wait :: ProcessHandle -> String -> IO ()
- wait h msg = do
- r <- waitForProcess h
- unless (r == ExitSuccess) $ do
- hPutStrLn stderr msg
- exitFailure
-
-check :: [FilePath] -> Bool -> IO ()
-check modules strict = do
- forM_ modules $ \mod -> do
- let outfile = outDir </> dropExtension mod ++ ".html"
- let reffile = refDir </> dropExtension mod ++ ".html"
- b <- doesFileExist reffile
- if b
- then do
- out <- readFile outfile
- ref <- readFile reffile
- if not $ haddockEq (outfile, out) (reffile, ref)
- then do
- putStrLn $ "Output for " ++ mod ++ " has changed! Exiting with diff:"
- let ref' = maybeStripLinks outfile ref
- out' = maybeStripLinks reffile out
- let reffile' = outDir </> takeFileName reffile ++ ".nolinks"
- outfile' = outDir </> takeFileName outfile ++ ".ref.nolinks"
- writeFile reffile' ref'
- writeFile outfile' out'
- r <- programOnPath "colordiff"
- code <- if r
- then system $ "colordiff " ++ reffile' ++ " " ++ outfile'
- else system $ "diff " ++ reffile' ++ " " ++ outfile'
- if strict then exitFailure else return ()
- unless (code == ExitSuccess) $ do
- hPutStrLn stderr "*** Running diff failed!"
- exitFailure
- else do
- putStrLn $ "Pass: " ++ mod
- else do
- putStrLn $ "Pass: " ++ mod ++ " (no .ref file)"
-
--- | List of modules in which we don't 'stripLinks'
-preserveLinksModules :: [String]
-preserveLinksModules = map (++ ".html") ["Bug253"]
-
--- | A rather nasty way to drop the Haddock version string from the
--- end of the generated HTML files so that we don't have to change
--- every single test every time we change versions. We rely on the the
--- last paragraph of the document to be the version. We end up with
--- malformed HTML but we don't care as we never look at it ourselves.
-dropVersion :: String -> String
-dropVersion = reverse . dropTillP . reverse
- where
- dropTillP [] = []
- dropTillP ('p':'<':xs) = xs
- dropTillP (_:xs) = dropTillP xs
-
-haddockEq :: (FilePath, String) -> (FilePath, String) -> Bool
-haddockEq (fn1, file1) (fn2, file2) =
- maybeStripLinks fn1 (dropVersion file1)
- == maybeStripLinks fn2 (dropVersion file2)
-
-maybeStripLinks :: String -- ^ Module we're considering for stripping
- -> String -> String
-maybeStripLinks m = if any (`isSuffixOf` m) preserveLinksModules
- then id
- else stripLinks
-
-stripLinks :: String -> String
-stripLinks str =
- let prefix = "<a href=\"" in
- case stripPrefix prefix str of
- Just str' -> case dropWhile (/= '>') (dropWhile (/= '"') str') of
- [] -> []
- x:xs -> stripLinks (stripHrefEnd xs)
- Nothing ->
- case str of
- [] -> []
- x : xs -> x : stripLinks xs
-
-stripHrefEnd :: String -> String
-stripHrefEnd s =
- let pref = "</a" in
- case stripPrefix pref s of
- Just str' -> case dropWhile (/= '>') str' of
- [] -> []
- x:xs -> xs
- Nothing ->
- case s of
- [] -> []
- x : xs -> x : stripHrefEnd xs
-
-programOnPath :: FilePath -> IO Bool
-programOnPath p = do
- result <- findProgramLocation silent p
- return (isJust result)
-\end{code}
diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs
new file mode 100644
index 00000000..0490be47
--- /dev/null
+++ b/hypsrc-test/Main.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE CPP #-}
+
+
+import Data.Char
+import Data.List
+
+import System.Environment
+import System.FilePath
+
+import Test.Haddock
+import Test.Haddock.Xhtml
+
+
+checkConfig :: CheckConfig Xml
+checkConfig = CheckConfig
+ { ccfgRead = \_ input -> strip <$> parseXml input
+ , ccfgDump = dumpXml
+ , ccfgEqual = (==)
+ }
+ where
+ strip = stripAnchors' . stripLinks' . stripFooter
+ stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href
+ stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name
+
+
+dirConfig :: DirConfig
+dirConfig = (defaultDirConfig $ takeDirectory __FILE__)
+ { dcfgCheckIgnore = checkIgnore
+ }
+
+
+main :: IO ()
+main = do
+ cfg <- parseArgs checkConfig dirConfig =<< getArgs
+ runAndCheck $ cfg
+ { cfgHaddockArgs = cfgHaddockArgs cfg ++
+ [ "--pretty-html"
+ , "--hyperlinked-source"
+ ]
+ }
+
+
+checkIgnore :: FilePath -> Bool
+checkIgnore file
+ | and . map ($ file) $ [isHtmlFile, isSourceFile, isModuleFile] = False
+ where
+ isHtmlFile = (== ".html") . takeExtension
+ isSourceFile = (== "src") . takeDirectory
+ isModuleFile = isUpper . head . takeBaseName
+checkIgnore _ = True
diff --git a/hypsrc-test/Utils.hs b/hypsrc-test/Utils.hs
deleted file mode 100644
index e15fabee..00000000
--- a/hypsrc-test/Utils.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-
-module Utils
- ( baseDir, rootDir
- , srcDir, refDir, outDir, refDir', outDir'
- , haddockPath
- , stripLocalAnchors, stripLocalLinks, stripLocalReferences
- ) where
-
-
-import Data.List
-
-import System.FilePath
-
-
-baseDir, rootDir :: FilePath
-baseDir = takeDirectory __FILE__
-rootDir = baseDir </> ".."
-
-srcDir, refDir, outDir, refDir', outDir' :: FilePath
-srcDir = baseDir </> "src"
-refDir = baseDir </> "ref"
-outDir = baseDir </> "out"
-refDir' = refDir </> "src"
-outDir' = outDir </> "src"
-
-haddockPath :: FilePath
-haddockPath = rootDir </> "dist" </> "build" </> "haddock" </> "haddock"
-
-
-replaceBetween :: Eq a => [a] -> a -> [a] -> [a] -> [a]
-replaceBetween _ _ _ [] = []
-replaceBetween pref end val html@(x:xs') = case stripPrefix pref html of
- Just strip -> pref ++ val ++ (replaceBetween' . dropWhile (/= end)) strip
- Nothing -> x:(replaceBetween' xs')
- where
- replaceBetween' = replaceBetween pref end val
-
-stripLocalAnchors :: String -> String
-stripLocalAnchors = replaceBetween "<a name=\"local-" '\"' "0"
-
-stripLocalLinks :: String -> String
-stripLocalLinks = replaceBetween "<a href=\"#local-" '\"' "0"
-
-stripLocalReferences :: String -> String
-stripLocalReferences = stripLocalLinks . stripLocalAnchors
diff --git a/hypsrc-test/accept.hs b/hypsrc-test/accept.hs
deleted file mode 100755
index 4606b2df..00000000
--- a/hypsrc-test/accept.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-#!/usr/bin/env runhaskell
-{-# LANGUAGE CPP #-}
-
-
-import System.Directory
-import System.FilePath
-import System.Environment
-
-import Utils
-
-
-main :: IO ()
-main = do
- args <- getArgs
- files <- filter isHtmlFile <$> getDirectoryContents outDir'
- let files' = if args == ["--all"] || args == ["-a"]
- then files
- else filter ((`elem` args) . takeBaseName) files
- mapM_ copy files'
- where
- isHtmlFile = (== ".html") . takeExtension
-
-
-copy :: FilePath -> IO ()
-copy file = do
- content <- stripLocalReferences <$> readFile (outDir' </> file)
- writeFile (refDir' </> file) content
diff --git a/hypsrc-test/run b/hypsrc-test/run
new file mode 100755
index 00000000..3e72be80
--- /dev/null
+++ b/hypsrc-test/run
@@ -0,0 +1,6 @@
+#!/usr/bin/env bash
+
+export HADDOCK_PATH=$(which haddock)
+LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/"
+MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs"
+runhaskell -i:"$LIB_PATH" $MAIN_PATH $@
diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs
deleted file mode 100755
index 853c4f09..00000000
--- a/hypsrc-test/run.hs
+++ /dev/null
@@ -1,122 +0,0 @@
-#!/usr/bin/env runhaskell
-{-# LANGUAGE CPP #-}
-
-
-import Control.Monad
-
-import Data.List
-import Data.Maybe
-
-import System.Directory
-import System.Environment
-import System.Exit
-import System.FilePath
-import System.Process
-
-import Distribution.Verbosity
-import Distribution.Simple.Utils hiding (die)
-
-import Utils
-
-
-main :: IO ()
-main = do
- haddockAvailable <- doesFileExist haddockPath
- unless haddockAvailable $ die "Haddock exectuable not available"
-
- (args, mods) <- partition ("-" `isPrefixOf`) <$> getArgs
- let args' = filter (\arg -> not $ arg == "--all" || arg == "-a") args
- mods' <- map (srcDir </>) <$> case args of
- [] -> getAllSrcModules
- _ -> return $ map (++ ".hs") mods
-
- putHaddockVersion
- putGhcVersion
-
- putStrLn "Running tests..."
- runHaddock $
- [ "--odir=" ++ outDir
- , "--no-warnings"
- , "--hyperlinked-source"
- , "--pretty-html"
- ] ++ args' ++ mods'
-
- forM_ mods' $ check True
-
-
-check :: Bool -> FilePath -> IO ()
-check strict mdl = do
- hasReference <- doesFileExist refFile
- if hasReference
- then do
- ref <- readFile refFile
- out <- readFile outFile
- compareOutput strict mdl ref out
- else do
- putStrLn $ "Pass: " ++ mdl ++ " (no reference file)"
- where
- refFile = refDir' </> takeBaseName mdl ++ ".html"
- outFile = outDir' </> takeBaseName mdl ++ ".html"
-
-
-compareOutput :: Bool -> FilePath -> String -> String -> IO ()
-compareOutput strict mdl ref out = do
- if ref' == out'
- then putStrLn $ "Pass: " ++ mdl
- else do
- putStrLn $ "Fail: " ++ mdl
- diff mdl ref' out'
- when strict $ die "Aborting further tests."
- where
- ref' = stripLocalReferences ref
- out' = stripLocalReferences out
-
-
-diff :: FilePath -> String -> String -> IO ()
-diff mdl ref out = do
- colorDiffPath <- findProgramLocation silent "colordiff"
- let cmd = fromMaybe "diff" colorDiffPath
-
- writeFile refFile ref
- writeFile outFile out
-
- result <- system $ cmd ++ " " ++ refFile ++ " " ++ outFile
- unless (result == ExitSuccess) $ die "Failed to run `diff` command."
- where
- refFile = outDir </> takeBaseName mdl ++ ".ref.nolinks"
- outFile = outDir </> takeBaseName mdl ++ ".nolinks"
-
-
-
-getAllSrcModules :: IO [FilePath]
-getAllSrcModules =
- filter isHaskellFile <$> getDirectoryContents srcDir
- where
- isHaskellFile = (== ".hs") . takeExtension
-
-
-putHaddockVersion :: IO ()
-putHaddockVersion = do
- putStrLn "Haddock version:"
- runHaddock ["--version"]
- putStrLn ""
-
-
-putGhcVersion :: IO ()
-putGhcVersion = do
- putStrLn "GHC version:"
- runHaddock ["--ghc-version"]
- putStrLn ""
-
-
-runHaddock :: [String] -> IO ()
-runHaddock args = do
- menv <- Just <$> getEnvironment
- handle <- runProcess haddockPath args Nothing menv Nothing Nothing Nothing
- waitForSuccess handle $ "Failed to invoke haddock with " ++ show args
-
-
-waitForSuccess :: ProcessHandle -> String -> IO ()
-waitForSuccess handle msg = do
- result <- waitForProcess handle
- unless (result == ExitSuccess) $ die msg
diff --git a/latex-test/Main.hs b/latex-test/Main.hs
new file mode 100755
index 00000000..2ee01a26
--- /dev/null
+++ b/latex-test/Main.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE CPP #-}
+
+
+import System.Environment
+import System.FilePath
+
+import Test.Haddock
+
+
+checkConfig :: CheckConfig String
+checkConfig = CheckConfig
+ { ccfgRead = \_ input -> Just input
+ , ccfgDump = id
+ , ccfgEqual = (==)
+ }
+
+
+dirConfig :: DirConfig
+dirConfig = defaultDirConfig $ takeDirectory __FILE__
+
+
+main :: IO ()
+main = do
+ cfg <- parseArgs checkConfig dirConfig =<< getArgs
+ runAndCheck $ cfg
+ { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--latex"]
+ }
diff --git a/latex-test/accept.lhs b/latex-test/accept.lhs
deleted file mode 100755
index 4d0b0127..00000000
--- a/latex-test/accept.lhs
+++ /dev/null
@@ -1,46 +0,0 @@
-#!/usr/bin/env runhaskell
-\begin{code}
-{-# LANGUAGE CPP #-}
-import System.Environment
-import System.FilePath
-import System.Directory
-import Data.List
-import Control.Applicative
-import Control.Monad
-
-baseDir :: FilePath
-baseDir = takeDirectory __FILE__
-
-main :: IO ()
-main = do
- contents <- filter (not . ignore) <$> getDirectoryContents (baseDir </> "out")
- args <- getArgs
- mapM_ copyDir $ if not (null args)
- then filter ((`elem` args) . takeBaseName) contents
- else contents
- where
- ignore =
- foldr (liftA2 (||)) (const False) [
- (== ".")
- , (== "..")
- , isPrefixOf "index"
- , isPrefixOf "doc-index"
- ]
-
--- | Copy a directory to ref, one level deep.
-copyDir :: FilePath -> IO ()
-copyDir dir = do
- let old = baseDir </> "out" </> dir
- new = baseDir </> "ref" </> dir
- alreadyExists <- doesDirectoryExist new
- unless alreadyExists $ do
- putStrLn (old ++ " -> " ++ new)
- createDirectoryIfMissing True new
- files <- getDirectoryContents old >>= filterM (liftM not . doesDirectoryExist)
- let files' = filter (\x -> x /= "." && x /= "..") files
- mapM_ (\f -> copyFile' (old </> f) (new </> f)) files'
- where
- copyFile' o n = do
- putStrLn $ o ++ " -> " ++ n
- copyFile o n
-\end{code}
diff --git a/latex-test/ref/Simple/Simple.tex b/latex-test/ref/Simple/Simple.tex
index 89e849f8..5ba4712c 100644
--- a/latex-test/ref/Simple/Simple.tex
+++ b/latex-test/ref/Simple/Simple.tex
@@ -11,7 +11,6 @@ module Simple (
\item[\begin{tabular}{@{}l}
foo\ ::\ t
\end{tabular}]\haddockbegindoc
-This is foo.
-\par
+This is foo.\par
\end{haddockdesc} \ No newline at end of file
diff --git a/latex-test/run b/latex-test/run
new file mode 100755
index 00000000..3e72be80
--- /dev/null
+++ b/latex-test/run
@@ -0,0 +1,6 @@
+#!/usr/bin/env bash
+
+export HADDOCK_PATH=$(which haddock)
+LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/"
+MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs"
+runhaskell -i:"$LIB_PATH" $MAIN_PATH $@
diff --git a/latex-test/run.lhs b/latex-test/run.lhs
deleted file mode 100755
index d3e39e90..00000000
--- a/latex-test/run.lhs
+++ /dev/null
@@ -1,162 +0,0 @@
-#!/usr/bin/env runhaskell
-\begin{code}
-{-# LANGUAGE CPP #-}
-import Prelude hiding (mod)
-import Control.Monad
-import Control.Applicative
-import Data.List
-import Data.Maybe
-import Distribution.InstalledPackageInfo hiding (dataDir)
-import Distribution.Package (PackageName (..))
-import Distribution.Simple.Compiler
-import Distribution.Simple.GHC
-import Distribution.Simple.PackageIndex
-import Distribution.Simple.Program
-import Distribution.Simple.Utils
-import Distribution.Verbosity
-import System.IO
-import System.Directory
-import System.Environment
-import System.Exit
-import System.FilePath
-import System.Process (ProcessHandle, runProcess, waitForProcess, system)
-
-
-packageRoot, dataDir, haddockPath, baseDir, testDir, outDir, refDir :: FilePath
-baseDir = takeDirectory __FILE__
-testDir = baseDir </> "src"
-refDir = baseDir </> "ref"
-outDir = baseDir </> "out"
-packageRoot = baseDir </> ".."
-dataDir = packageRoot </> "resources"
-haddockPath = packageRoot </> "dist" </> "build" </> "haddock" </> "haddock"
-
-
-main :: IO ()
-main = do
- test
- putStrLn "All tests passed!"
-
-
-test :: IO ()
-test = do
- x <- doesFileExist haddockPath
- unless x $ System.Exit.die "you need to run 'cabal build' successfully first"
-
- contents <- getDirectoryContents testDir
-
- args <- getArgs
- let (opts, spec) = span ("-" `isPrefixOf`) args
- isDir x' = liftM2 (&&) (doesDirectoryExist $ testDir </> x')
- (return $ x' /= "." && x' /= "..")
- modDirs <- case spec of
- y:_ | y /= "all" -> return [y]
- _ -> filterM isDir contents
-
- let modDirs' = map (testDir </>) modDirs
-
- -- add haddock_datadir to environment for subprocesses
- env <- Just . (:) ("haddock_datadir", dataDir) <$> getEnvironment
-
- putStrLn ""
- putStrLn "Haddock version: "
- h1 <- runProcess haddockPath ["--version"] Nothing
- env Nothing Nothing Nothing
- wait h1 "*** Running `haddock --version' failed!"
- putStrLn ""
- putStrLn "GHC version: "
- h2 <- runProcess haddockPath ["--ghc-version"] Nothing
- env Nothing Nothing Nothing
- wait h2 "*** Running `haddock --ghc-version' failed!"
- putStrLn ""
-
- -- TODO: maybe do something more clever here using haddock.cabal
- ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"]
- (_, _, conf) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration
- pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf
- let mkDep pkgName =
- fromMaybe (error "Couldn't find test dependencies") $ do
- let pkgs = lookupPackageName pkgIndex (PackageName pkgName)
- (_, pkgs') <- listToMaybe pkgs
- pkg <- listToMaybe pkgs'
- ifacePath <- listToMaybe (haddockInterfaces pkg)
- htmlPath <- listToMaybe (haddockHTMLs pkg)
- return ("-i " ++ htmlPath ++ "," ++ ifacePath)
-
- let base = mkDep "base"
- process = mkDep "process"
- ghcprim = mkDep "ghc-prim"
-
- putStrLn "Running tests..."
-
- forM_ modDirs' $ \modDir -> do
- testModules <- getDirectoryContents modDir
-
- let mods = filter ((==) ".hs" . takeExtension) testModules
- mods' = map (modDir </>) mods
-
- unless (null mods') $ do
- handle <- runProcess haddockPath
- (["-w", "-o", outDir </> last (splitPath modDir), "--latex"
- , "--optghc=-fglasgow-exts"
- , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
- Nothing env Nothing
- Nothing Nothing
-
- wait handle "*** Haddock run failed! Exiting."
-
- check modDirs (if not (null args) && args !! 0 == "all" then False else True)
- where
- wait :: ProcessHandle -> String -> IO ()
- wait h msg = do
- r <- waitForProcess h
- unless (r == ExitSuccess) $ do
- hPutStrLn stderr msg
- exitFailure
-
-check :: [FilePath] -> Bool -> IO ()
-check modDirs strict = do
- forM_ modDirs $ \modDir -> do
- let oDir = outDir </> modDir
- rDir = refDir </> modDir
-
- refDirExists <- doesDirectoryExist rDir
- when refDirExists $ do
- -- we're not creating sub-directories, I think.
- refFiles <- getDirectoryContents rDir >>= filterM doesFileExist
-
- forM_ refFiles $ \rFile -> do
- let refFile = rDir </> rFile
- outFile = oDir </> rFile
- oe <- doesFileExist outFile
- if oe
- then do
- out <- readFile outFile
- ref <- readFile refFile
-
- if out /= ref
- then do
- putStrLn $ "Output for " ++ modDir ++ " has changed! Exiting with diff:"
-
- let reffile' = outDir </> takeFileName refFile ++ ".nolinks"
- outfile' = outDir </> takeFileName outFile ++ ".ref.nolinks"
- writeFile reffile' ref
- writeFile outfile' out
- r <- programOnPath "colordiff"
- code <- if r
- then system $ "colordiff " ++ reffile' ++ " " ++ outfile'
- else system $ "diff " ++ reffile' ++ " " ++ outfile'
- if strict then exitFailure else return ()
- unless (code == ExitSuccess) $ do
- hPutStrLn stderr "*** Running diff failed!"
- exitFailure
- else do
- putStrLn $ "Pass: " ++ modDir
- else do
- putStrLn $ "Pass: " ++ modDir ++ " (no .ref file)"
-
-programOnPath :: FilePath -> IO Bool
-programOnPath p = do
- result <- findProgramLocation silent p
- return (isJust result)
-\end{code}