aboutsummaryrefslogtreecommitdiff
path: root/html-test
diff options
context:
space:
mode:
Diffstat (limited to 'html-test')
-rwxr-xr-xhtml-test/Main.hs51
-rw-r--r--html-test/README.markdown27
-rwxr-xr-xhtml-test/accept.lhs49
-rw-r--r--html-test/ref/OrphanInstances.html113
-rw-r--r--html-test/ref/OrphanInstancesClass.html85
-rw-r--r--html-test/ref/OrphanInstancesType.html81
-rwxr-xr-xhtml-test/run6
-rwxr-xr-xhtml-test/run.lhs191
-rw-r--r--html-test/src/Operators.hs6
-rw-r--r--html-test/src/OrphanInstances.hs8
-rw-r--r--html-test/src/OrphanInstancesClass.hs4
-rw-r--r--html-test/src/OrphanInstancesType.hs3
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"
+ >&nbsp;</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
+ > -&gt; <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"
+ >&nbsp;</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 -&gt; <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"
+ >&nbsp;</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"
+ >&nbsp;</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