diff options
Diffstat (limited to 'html-test')
| -rwxr-xr-x | html-test/Main.hs | 51 | ||||
| -rw-r--r-- | html-test/README.markdown | 27 | ||||
| -rwxr-xr-x | html-test/accept.lhs | 49 | ||||
| -rw-r--r-- | html-test/ref/OrphanInstances.html | 113 | ||||
| -rw-r--r-- | html-test/ref/OrphanInstancesClass.html | 85 | ||||
| -rw-r--r-- | html-test/ref/OrphanInstancesType.html | 81 | ||||
| -rwxr-xr-x | html-test/run | 6 | ||||
| -rwxr-xr-x | html-test/run.lhs | 191 | ||||
| -rw-r--r-- | html-test/src/Operators.hs | 6 | ||||
| -rw-r--r-- | html-test/src/OrphanInstances.hs | 8 | ||||
| -rw-r--r-- | html-test/src/OrphanInstancesClass.hs | 4 | ||||
| -rw-r--r-- | html-test/src/OrphanInstancesType.hs | 3 |
12 files changed, 356 insertions, 268 deletions
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/ref/OrphanInstances.html b/html-test/ref/OrphanInstances.html new file mode 100644 index 00000000..0f12bb2e --- /dev/null +++ b/html-test/ref/OrphanInstances.html @@ -0,0 +1,113 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >OrphanInstances</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_OrphanInstances.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="index.html" + >Contents</a + ></li + ><li + ><a href="doc-index.html" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >OrphanInstances</p + ></div + ><div id="table-of-contents" + ><p class="caption" + >Contents</p + ><ul + ><li + ><a href="#section.orphans" + >Orphan instances</a + ></li + ></ul + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><h1 + >Orphan instances</h1 + ><div id="section.orphans" class="show" + ><table + ><tr + ><td class="src clearfix" + ><span class="inst-left" + ><span id="control.i:o:ic:AClass:AClass:1" class="instance expander" onclick="toggleSection('i:o:ic:AClass:AClass:1')" + ></span + > <a href="OrphanInstancesClass.html#t:AClass" + >AClass</a + > <a href="OrphanInstancesType.html#t:AType" + >AType</a + ></span + ></td + ><td class="doc" + ><p + >This is an orphan instance.</p + ></td + ></tr + ><tr + ><td colspan="2" + ><div id="section.i:o:ic:AClass:AClass:1" class="inst-details hide" + ><div class="subs methods" + ><p class="caption" + >Methods</p + ><p class="src" + ><a href="#v:aClass" + >aClass</a + > :: <a href="OrphanInstancesType.html#t:AType" + >AType</a + > -> <a href="/opt/exp/ghc/roots/landing/share/doc/ghc/html/libraries/base-4.9.0.0/Data-Int.html#t:Int" + >Int</a + ></p + ></div + ></div + ></td + ></tr + ></table + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="http://www.haskell.org/haddock/" + >Haddock</a + > version 2.16.2</p + ></div + ></body + ></html +> diff --git a/html-test/ref/OrphanInstancesClass.html b/html-test/ref/OrphanInstancesClass.html new file mode 100644 index 00000000..69ba33f8 --- /dev/null +++ b/html-test/ref/OrphanInstancesClass.html @@ -0,0 +1,85 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >OrphanInstancesClass</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_OrphanInstancesClass.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="index.html" + >Contents</a + ></li + ><li + ><a href="doc-index.html" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >OrphanInstancesClass</p + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="#t:AClass" id="t:AClass" class="def" + >AClass</a + > a <span class="keyword" + >where</span + ></p + ><div class="subs minimal" + ><p class="caption" + >Minimal complete definition</p + ><p class="src" + ><a href="OrphanInstancesClass.html#v:aClass" + >aClass</a + ></p + ></div + ><div class="subs methods" + ><p class="caption" + >Methods</p + ><p class="src" + ><a href="#v:aClass" id="v:aClass" class="def" + >aClass</a + > :: a -> <a href="/opt/exp/ghc/roots/landing/share/doc/ghc/html/libraries/base-4.9.0.0/Data-Int.html#t:Int" + >Int</a + ></p + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="http://www.haskell.org/haddock/" + >Haddock</a + > version 2.16.2</p + ></div + ></body + ></html +> diff --git a/html-test/ref/OrphanInstancesType.html b/html-test/ref/OrphanInstancesType.html new file mode 100644 index 00000000..2652db73 --- /dev/null +++ b/html-test/ref/OrphanInstancesType.html @@ -0,0 +1,81 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >OrphanInstancesType</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_OrphanInstancesType.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="index.html" + >Contents</a + ></li + ><li + ><a href="doc-index.html" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >OrphanInstancesType</p + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="#t:AType" id="t:AType" class="def" + >AType</a + ></p + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a href="#v:AType" id="v:AType" class="def" + >AType</a + > <a href="/opt/exp/ghc/roots/landing/share/doc/ghc/html/libraries/base-4.9.0.0/Data-Int.html#t:Int" + >Int</a + ></td + ><td class="doc empty" + > </td + ></tr + ></table + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="http://www.haskell.org/haddock/" + >Haddock</a + > version 2.16.2</p + ></div + ></body + ></html +> 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/html-test/src/Operators.hs b/html-test/src/Operators.hs index f7b4d0ab..0b633c3f 100644 --- a/html-test/src/Operators.hs +++ b/html-test/src/Operators.hs @@ -1,4 +1,6 @@ {-# LANGUAGE PatternSynonyms, TypeOperators, TypeFamilies, MultiParamTypeClasses, GADTs #-} +{-# LANGUAGE FunctionalDependencies #-} + -- | Test operators with or without fixity declarations module Operators where @@ -42,7 +44,9 @@ data family a ** b infix 9 ** -- | Class with fixity, including associated types -class a ><> b where +class a ><> b | a -> b where + -- Dec 2015: Added @a -> b@ functional dependency to clean up ambiguity + -- See GHC #11264 type a <>< b :: * data a ><< b (>><), (<<>) :: a -> b -> () diff --git a/html-test/src/OrphanInstances.hs b/html-test/src/OrphanInstances.hs new file mode 100644 index 00000000..e50327ee --- /dev/null +++ b/html-test/src/OrphanInstances.hs @@ -0,0 +1,8 @@ +module OrphanInstances where + +import OrphanInstancesType +import OrphanInstancesClass + +-- | This is an orphan instance. +instance AClass AType where + aClass (AType n) = n diff --git a/html-test/src/OrphanInstancesClass.hs b/html-test/src/OrphanInstancesClass.hs new file mode 100644 index 00000000..4b51acfc --- /dev/null +++ b/html-test/src/OrphanInstancesClass.hs @@ -0,0 +1,4 @@ +module OrphanInstancesClass (AClass(..)) where + +class AClass a where + aClass :: a -> Int diff --git a/html-test/src/OrphanInstancesType.hs b/html-test/src/OrphanInstancesType.hs new file mode 100644 index 00000000..b3c3145e --- /dev/null +++ b/html-test/src/OrphanInstancesType.hs @@ -0,0 +1,3 @@ +module OrphanInstancesType (AType(..)) where + +data AType = AType Int |